PDA

View Full Version : VBA code help (current code too slow and freezes)



xxsinghxx
09-12-2017, 01:01 PM
Hi,

I do these manual steps on daily basis and would like to make the file automated. I tried recording the steps via macro and whenever I run it freezes or takes a long time to complete steps. Can anyone please review this generic code and convert it into a clean, faster, and efficient code? Please

Thank you for your help with this request in advance!!

austenr
09-12-2017, 01:16 PM
well to start with your speed will be greatly increased if you add this line athe the first line of your sub:

Application.Calculation = xlManual


then the last line should be

Application.Calculation = xlAutomatic

Dont have time to look at the rest right now

xxsinghxx
09-12-2017, 02:03 PM
These two additions helped. I think the vlookup formulas are taking too much time updating....

offthelip
09-12-2017, 02:31 PM
you don't need to use Vlookup at at all, for really fast code use variant arrays. We have just had a long discussion about this on an almost identical case to yours on this thread:
http://www.vbaexpress.com/forum/showthread.php?60605-Excel-Slow-performance

offthelip
09-12-2017, 04:55 PM
I am not sure whether I have got this exactly right but it should give you the way forward;


Sub Macro3() Dim txt As String
Dim bdarr As Variant

Worksheets("Sheet1").Range("B:B").Copy Destination:=ActiveSheet.Range("A:A")
With Worksheets("Sheet1")
lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
End With
' Selection.Copy
Sheets("Sheet2").Select
d1 = Cells(1, 4).Value
e1 = Cells(1, 5).Value

ActiveSheet.Range("$A$1:$A$82452").RemoveDuplicates Columns:=1, Header:= _
xlNo
outarr = Range(Cells(1, 2), Cells(7881, 6))
cola = Range(Cells(1, 1), Cells(7881, 1))
With Worksheets("Sheet1")
For i = 2 To 7881
For k = 1 To 4
outarr(i, k) = ""
Next k
txt = cola(i, 1)
If txt <> "" Then
outarr(i, 1) = Application.WorksheetFunction.VLookup(txt, Range(.Cells(1, 2), .Cells(lastrow, 4)), 3, False)
outarr(i, 2) = Left(outarr(i, 1), 1)
outarr(i, 3) = Application.WorksheetFunction.CountIfs(Range(.Cells(1, 2), .Cells(lastrow, 2)), txt, Range(.Cells(1, 5), .Cells(lastrow, 5)), d1)
outarr(i, 4) = Application.WorksheetFunction.CountIfs(Range(.Cells(1, 2), .Cells(lastrow, 2)), txt, Range(.Cells(1, 5), .Cells(lastrow, 5)), e1)
outarr(i, 5) = outarr(i, 3) + outarr(i, 4)
End If
Next i
End With
Range(Cells(1, 2), Cells(7881, 6)) = outarr



ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("F2:F7881" _
), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("A1:F7881")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub

p45cal
09-13-2017, 05:37 AM
You're sorting twice, once on a range full of formulae (this is slow); convert to plain values first then sort.
The formulae also use entire columns unnecessarily.
See if this works any faster (there are comments in the code):
Sub blah()
Application.ScreenUpdating = False
Sht1lastRow = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
With Sheets("Sheet2")
.UsedRange.Offset(1).Clear
Sheets("Sheet1").Range("B1:B" & Sht1lastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), Unique:=True
Sht2lastRow = .Range("A1").CurrentRegion.Rows.Count
.Range("B2:B" & Sht2lastRow).FormulaR1C1 = "=VLOOKUP(RC1,Sheet1!R1C2:R" & Sht1lastRow & "C4,3,FALSE)"
.Range("C2:C" & Sht2lastRow).FormulaR1C1 = "=LEFT(RC[-1],1)"
.Range("D2:E2" & Sht2lastRow).FormulaR1C1 = "=COUNTIFS(Sheet1!R1C2:R" & Sht1lastRow & "C2,RC1,Sheet1!R1C5:R" & Sht1lastRow & "C5,R1C)"
'.Range("D2:E" & Sht2lastRow).FormulaR1C1 = "=SUMPRODUCT((Sheet1!R1C2:R" & Sht1lastRow & "C2=RC1)*(Sheet1!R1C5:R" & Sht1lastRow & "C5=R1C))" 'for my Excel2003 without COUNTIFS. Delete.
'ActiveWorkbook.Save 'why?
.Range("F2:F" & Sht2lastRow).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
.Range("B2:F" & Sht2lastRow).Value = Range("B2:F" & Sht2lastRow).Value
' With ActiveWorkbook.Worksheets("Sheet2").Sort 'resort to this sorting (these 10 lines) if below sorting fails.
' .SortFields.Clear
' .SortFields.Add Key:=Range("F2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
' .SetRange Range("A1:F" & Sht2lastRow)
' .Header = xlYes
' .MatchCase = False
' .Orientation = xlTopToBottom
' .SortMethod = xlPinYin
' .Apply
' End With
.Range("A1:F" & Sht2lastRow).Sort Key1:=Range("F2"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 'Excel 2003 sorting; you can probably keep.
Application.Goto .Range("A1")
End With
Application.ScreenUpdating = True
End Sub
Note that in your Sheet 1 data there is one PART which goes to 2 places: P12 goes to TO12 and TO88. This is not reflected in the results, everything goes to TO12.

Another way to do this is to set up a pivot table, then all you have to do is change the Pivot's source data when you get new data.

p45cal
09-13-2017, 07:07 AM
oh groan…

cross posted without links:
https://www.excelforum.com/excel-programming-vba-macros/1200705-vba-code-help-current-code-too-slow-and-freezes.html

xxsinghxx, for your information, you should always provide links to your cross posts.
This is a requirement, not just a request.
If you have cross posted at other places, please add links to them too.
Why? Have a read of http://www.excelguru.ca/content.php?184