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