Search code examples
excelvba

Set Interior.Color of Range to Interior.Color of another Range of the same size

i am working on a sort of graphics api in Excel, where i need to display textures. I am displaying them as a range, where the cells are painted. To display it i need to set the interior.color of each cell of range1 to the interior.color of each cell of range2. The simple solution would be a for each loop but im trying to get it to a oneliner for performance reasons. The code is:

Public Sub Initialize(ByVal WorkbookName As String, ByVal SheetName As String, ByVal n_SheetRow As Long, ByVal n_SheetColumn As Long, ByVal n_LastRow As Long, ByVal n_LastColumn As Long)
    Dim TextureSheet As Range
    p_SheetRow = n_SheetRow
    p_SheetColumn = n_SheetColumn
    p_LastRow = n_LastRow
    p_LastColumn = n_LastColumn
    Set TextureSheet = Workbooks(WorkbookName).Sheets(SheetName).Range("A1")
1.  Set p_OriginalTexture = Range(TextureSheet.Offset(p_SheetRow, p_SheetColumn), TextureSheet.Offset(p_SheetRow + p_LastRow, p_SheetColumn + p_LastColumn))
2.  p_OriginalTexture.Interior.Color = Range(TextureSheet.Offset(p_SheetRow, p_SheetColumn), TextureSheet.Offset(p_SheetRow + p_LastRow, p_SheetColumn + p_LastColumn)).DisplayFormat.Interior.Color
    p_OriginalTexture.Select
    Set p_Texture = p_OriginalTexture.Offset(p_LastRow + 1, 0)
    p_Texture.Interior.Color = p_OriginalTexture.Interior.Color
    p_Initialized = True
End Sub

Upper cell block SHOULD be the texture and it SHOULD paste these colors to the black block

SheetRow, SheetColumn, LastRow and LastColumn are properties of the Texture-class and are used to describe the position and size of the texture.

p_OriginalTexture is set once in initialization. p_Texture is the one being used as texture later on.

  1. was my first idea. Doing this changed all the cells in p_Texture to black
  2. was my second idea. Doing this changed all the cells in p_Texture to black too
Solution

  • How about something like selecting the source range as above and then:

    Selection.Copy
Range("destination_range").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

    That should move just the textures and colours from the source range to the destination. And you can dispose of the first "Select" verb as well. ie

    Range("source_range").Copy