Macro Tweak

**Alex O** · 04-25-2011, 06:57 AM

Hello All,
I’m new to the site as well as VBA. After recently being introduced to vba, however, I’m rapidly discovering just how much time can be saved by going under the hood. That said, the macro posted below is a project I just finished and performs exactly as it should. The problem is it takes roughly two hours to run. Is there anyway the code can be trimmed a bit to speed up its performance? Any assistance is appreciated.

Sub CombineMe()
Dim C As Range
Dim lastRow As Long
lastRow = Range("K" & Rows.Count).End(xlUp).Row
For Each C In Range("K5:K" & lastRow)
    If C <> "" Then
        C.Offset(, 24).Value = C.Value & "-" & C.Offset(, 5).Value
   End If
Next C
End Sub

Sub ConcatDataV3()
' My macro for concatenating data fields that ultimately go in the comments field
Dim LR As Long, LR2 As Long, a As Long, aa As Long, SR As Long, ER As Long, H As String
Application.ScreenUpdating = False
LR = Cells(Rows.Count, "AF").End(xlUp).Row
Range("AK4:AN" & LR).ClearContents
Range("AF4:AF" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AK4"), Unique:=True
Range("AK4").ClearContents
LR2 = Cells(Rows.Count, "AK").End(xlUp).Row
Range("AM5").Formula = "=MATCH(AK5,AF:AF,0)"
Range("AM5").AutoFill Destination:=Range("AM5:AM" & LR2)
Range("AN5").Formula = "=AM6-1"
Range("AN5").AutoFill Destination:=Range("AN5:AN" & LR2 - 1)
Range("AN" & LR2) = LR
For a = 5 To LR2 Step 1
    SR = Range("AM" & a).Value
    ER = Range("AN" & a).Value
    H = ""
    For aa = SR To ER Step 1
        H = H & Cells(aa, "AI") & ", "
    Next aa
    If Right(H, 2) = ", " Then H = Left(H, Len(H) - 2)
    Range("AL" & a) = H
Next a
Range("AM5:AN" & LR2).ClearContents
Columns("AK:AL").AutoFit
Range("AK4").Select
Application.ScreenUpdating = True
End Sub
 
Sub ConcatDataV4()
' My macro for concatenating data fields that ultimately go in the comments field
Dim LR As Long, LR2 As Long, a As Long, aa As Long, SR As Long, ER As Long, H As String
Application.ScreenUpdating = False
LR = Cells(Rows.Count, "AF").End(xlUp).Row
Range("AO4:AR" & LR).ClearContents
Range("AF4:AF" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AO4"), Unique:=True
Range("AO4").ClearContents
LR2 = Cells(Rows.Count, "AO").End(xlUp).Row
Range("AQ5").Formula = "=MATCH(AO5,AF:AF,0)"
Range("AQ5").AutoFill Destination:=Range("AQ5:AQ" & LR2)
Range("AR5").Formula = "=AQ6-1"
Range("AR5").AutoFill Destination:=Range("AR5:AR" & LR2 - 1)
Range("AR" & LR2) = LR
For a = 5 To LR2 Step 1
    SR = Range("AQ" & a).Value
    ER = Range("AR" & a).Value
    H = ""
    For aa = SR To ER Step 1
        H = H & Cells(aa, "AS") & ", "
    Next aa
    If Right(H, 2) = ", " Then H = Left(H, Len(H) - 2)
    Range("AP" & a) = H
Next a
Range("AQ5:AR" & LR2).ClearContents
Columns("AO:AP").AutoFit
Range("AO4").Select
Application.ScreenUpdating = True
End Sub

Sub List Duplicates()
'Macro1 Macro
Dim C As Range
Dim EndRow As Long
Dim Countarray() As Long
For i = 1 To Range("Bi5").Value
    If Range("Bi" & i + 5) <> "" Then
        Range("Bi" & i + 5).Copy
        For j = 1 To 1000
            If Range("BL" & j + 5) = "" Then
                Range("BL" & j + 5).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                j = 1000
            Else
            End If
        Next j
    End If
Next i
For i = 1 To Range("Bj5").Value
    If Range("Bj" & i + 5) <> "" Then
        Range("Bj" & i + 5).Copy
        For j = 1 To 1000
            If Range("BL" & j + 5) = "" Then
                Range("BL" & j + 5).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                j = 1000
            Else
            End If
       Next j
    End If
Next i
For i = 1 To Range("Bk5").Value
    If Range("bk" & i + 5) <> "" Then
        Range("Bk" & i + 5).Copy
        For j = 1 To 1000
            If Range("BL" & j + 5) = "" Then
                Range("BL" & j + 5).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                j = 1000
            Else
            End If
        Next j
    End If
Next i
End Sub

**BrianMH** · 04-25-2011, 07:41 AM

Please use vba tags around your code.

Also if you can post an attachment for an example of data.

**Kenneth Hobs** · 04-25-2011, 08:13 AM

I wrote posted speed routines in the kb for just that reason. See the SpeedOn and SpeedOff routines at: http://www.vbaexpress.com/kb/getarticle.php?kb_id=1035

**Alex O** · 04-26-2011, 06:26 AM

I'm back....this is a sample of the actual file. T he actual file is way too large to post....

Thanks

**BrianMH** · 04-26-2011, 06:31 AM

Did you try the speed on script from the KB?

**Alex O** · 04-26-2011, 06:35 AM

I did. The problem is that there are dependant rages that require autocalc. The screenupdating False helps a little. I guess because I’m so new at this I wasn’t sure if there was superfluous code that was choking the run time. If not, I'll just leave it as is.....

**Kenneth Hobs** · 04-26-2011, 06:44 AM

One thing you can improve is to not use Select or Selection so much. Just Set a Range and use that which usually works just fine. I normally use Select or Activate for a final position or for special cases when working with some objects.

**Alex O** · 04-26-2011, 07:23 AM

Thanks for the suggestion. I making some changes now to see how it performs. To be continued....

**Alex O** · 04-26-2011, 08:19 AM

I've tried to edit the range selection but keep getting error messages. How would I edit this to limit the range selection? *an example of my edit is 'Range("AK4:AN2000" & LR).ClearContents'. Is this correct?

Sub ConcatDataV3() 
     ' My macro for concatenating data fields that ultimately go in the comments field
    Dim LR As Long, LR2 As Long, a As Long, aa As Long, SR As Long, ER As Long, H As String 
    Application.ScreenUpdating = False 
    LR = Cells(Rows.Count, "AF").End(xlUp).Row 
    Range("AK4:AN" & LR).ClearContents 
    Range("AF4:AF" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AK4"), Unique:=True 
    Range("AK4").ClearContents 
    LR2 = Cells(Rows.Count, "AK").End(xlUp).Row 
    Range("AM5").Formula = "=MATCH(AK5,AF:AF,0)" 
    Range("AM5").AutoFill Destination:=Range("AM5:AM" & LR2) 
    Range("AN5").Formula = "=AM6-1" 
    Range("AN5").AutoFill Destination:=Range("AN5:AN" & LR2 - 1) 
    Range("AN" & LR2) = LR 
    For a = 5 To LR2 Step 1 
        SR = Range("AM" & a).Value 
        ER = Range("AN" & a).Value 
        H = "" 
        For aa = SR To ER Step 1 
            H = H & Cells(aa, "AI") & ", " 
        Next aa 
        If Right(H, 2) = ", " Then H = Left(H, Len(H) - 2) 
        Range("AL" & a) = H 
    Next a 
    Range("AM5:AN" & LR2).ClearContents 
    Columns("AK:AL").AutoFit 
    Range("AK4").Select 
    Application.ScreenUpdating = True 
End Sub

Thread: Macro Tweak

Thread Tools

Display

Macro Tweak

Posting Permissions