3
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ Is each 5x10 area a single color? \$\endgroup\$ – Raystafarian May 10 '16 at 15:03
  • \$\begingroup\$ It can be a single color, but I would prefer it be open to multiple. With the current macro I can even make little pictures out of the 5x10 areas and have them appear all over the dataset. \$\endgroup\$ – schneiderwm May 10 '16 at 15:35
  • \$\begingroup\$ Okay so they aren't the same. And you said they overlap? So they need to overwrite in the right order? Do bold/italic/etc any other formatting need to be transferred? \$\endgroup\$ – Raystafarian May 10 '16 at 16:39
  • \$\begingroup\$ Yes, they need to overlap and overwrite, and no, nothing but the cell fill needs to be transferred. \$\endgroup\$ – schneiderwm May 10 '16 at 17:13
  • 1
    \$\begingroup\$ Welcome to Code Review! I have rolled back the last edit. Please see what you may and may not do after receiving answers. \$\endgroup\$ – Heslacher May 10 '16 at 17:38
1
\$\begingroup\$

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").

\$\endgroup\$
  • \$\begingroup\$ Better naming is a good tip. I'll expand on it. LegTra3 is just an abbreviated "Legend Transfer" third iteration. I'll try to standardize my coding in the future. I do work in a professional office, so it would be beneficial for others if I stuck to standards. I see and know the benefits of using named ranges and will probably switch to using this when I expand my legend and map. For the meantime I just want to make sure my method of transfer works well. Thanks for the tips. \$\endgroup\$ – schneiderwm May 10 '16 at 17:19
0
\$\begingroup\$

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
\$\endgroup\$
  • 2
    \$\begingroup\$ This isn't an answer, if you've improved the code and would like it review, please submit another question. I'd recommend waiting a bit for other answers. \$\endgroup\$ – Raystafarian May 10 '16 at 18:18

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.