VBA code help (current code too slow and freezes)

[xxsinghxx]

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]

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]

These two additions helped. I think the vlookup formulas are taking too much time updating....

[offthelip]

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/show...ow-performance

[offthelip]

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]

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]

oh groan…

cross posted without links:
https://www.excelforum.com/excel-pro...d-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