Transfer the cell formatting in a legend to a dataset in another sheet

Question

On Sheet 1 is a legend that contains unique values in Column A every ten rows. To the right of each value in the next five columns over are a series of color filled cells that extend down ten rows to the start of the next unique value. The color fill of each 5x10 area is what I want transferred to the dataset sheet.

The dataset is on Sheet2. The entirety of the paste area is filled with a dummy value so the macro works correctly. In the defined “paste to” columns in the macro I have, every so often, included a value already present in the legend where I want my color fill to be transferred. The “paste to” columns are within the area of paste, so it is possible for highlighted areas to overlap, which is necessary.

Using a macro, I want to copy and paste the 5x10 areas from the legend to the corresponding areas in the dataset sheet. So if a value is present in the dataset sheet and matches one of the unique values in the legend, I want the unique value 5x10 area to be pasted there in order from left to right, top to bottom, overlapping.

I’ve tried using the Find Method to do a lookup against the values in the dataset, and with that an offset function to tell the macro where to paste by cell. While this does work it is process intensive even with only a few columns and a limited legend.

How can I make it more efficient? Can I accomplish what I've explained via a better route? An array? I've toyed with using hex values and converting them into cell fills, if that would in anyway be more advantageous. A user by the name of gizlmeier has already cut my code down in size, however I've noticed the procedure time to be around the same.

Any ideas? Here’s what I have so far:

Sub LegTra3()

Dim i As Integer, j As Integer
Dim RngMap As Range, RngLeg As Range, RngCom As Range, RngTar As Range

Application.ScreenUpdating = False
Application.CutCopyMode = False

Set RngMap = Sheet2.Range("$A$1:$A$100,$D$1:$D$100,$G$1:$G$100") 'Columns spaced closer than width of legend fill to provide for overlap
Set RngLeg = Sheet1.Range("$A$1:$F$41")

For Each RngCom In RngMap
    Set RngTar = RngLeg.Find(What:=RngCom, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not RngTar Is Nothing Then
        For i = 0 To 9 Step 1
            For j = 0 To 4 Step 1
                RngTar.Offset(i, j + 1).Copy
                RngCom.Offset(i, j).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
            Next j
        Next i
    End If
Next
End Sub

Answer 1

Your naming isn't great, you should use variable names to describe what they do

Dim i As Integer
Dim j As Integer
Dim mapToFill As Range
Dim legend As Range 
Dim targetDestination As Range
Dim targetSource As Range

What is LegTra3 - I can't tell what that's supposed to mean at all.

Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names.

Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.

Instead of hard-coding cells, if they are static, assign them a named range property. e.g. instead of Sheets("mySheet").Range("A1:A10") you can have mysheet.Range("MyNamedRange").

Answer 2

OK, here is the same code as above, but with improved naming:

Sub LegendTransfer3()

Dim i As Long
Dim j As Long
Dim Map As Range
Dim Legend As Range
Dim DataPoint As Range
Dim Symbol As Range

Application.ScreenUpdating = False
Application.CutCopyMode = False

Set Map = Sheet2.Range("$A$1:$A$100,$D$1:$D$100,$G$1:$G$100") 'Columns spaced closer than width of legend fill to provide for overlap
Set Legend = Sheet1.Range("$A$1:$F$41")

Worksheets("Sheet2").Range("A1:M100").ClearFormats

For Each DataPoint In Map
    Set Symbol = Legend.Find(What:=DataPoint, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not Symbol Is Nothing Then
        For i = 0 To 9 Step 1
            For j = 0 To 4 Step 1
                Symbol.Offset(i, j + 1).Copy
                DataPoint.Offset(i, j).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
            Next j
        Next i
    End If
Next
End Sub