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
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