PDA

View Full Version : [SOLVED] 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