Best Practices and How to Speed up? - This Macro takes 16 mins to complete!

[wiseone]

Hi All,

Looking for suggestions on how to make this run faster would like to get from 16 mins to 5 mins... I'm very new to VB so I'm sure there are more efficient ways to doing everything that I've done.

If you take the time to go through this, thank you!

' This macro does the following:
'   STEP 1. Find the newest Extract from SAPRD in the target folder and Open it.
'   STEP 2. Find the newest Spec to Material number reference file. Do Not open it, it will be referenced only.
'   STEP 3. Insert Material columns on all tabs of extract file and vlookup spec to mat reference file.
'   STEP 4. Create a new tab in this file and generate a list of all unique material numbers included in the extract.
'   STEP 5. Vlookup all needed data from the individual tabs from the extract into the new tab.


Option Explicit


Public Const sNETWORK_PATH As String = "\\Camis2-mlf-fp01\dept_data\Consumer Foods\Meadowvale2\Master_Info\SecuredArea\SAP Extracts\Plant Extracts\"


Sub Generate_New_Extract_Tab()
         
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'SET PLANT NAME HERE, THIS MACRO WILL UPDATE TO CAPTURE ALL PLANT SPECIFIC FILES, NO OTHER CHANGES SHOULD BE NECESSARY.
    Const Plant_Name As String = "Heritage"   '<<<<<<update name="" here
    
    Dim FileSys As FileSystemObject
    Dim objFile As File
    Dim myFolder
    Dim extractsFilename As String
    Dim spectomatFilename As String
    Dim dteFile As Date
    Const extractsFolder As String = sNETWORK_PATH & "Extracts - " & Plant_Name & "\"
    Const spectomatFolder As String = sNETWORK_PATH & "SPEC TO MATERIAL NUM - GET FROM SAPRD\"


'********************************************************************************************************
'*  STEP 1 - Find the most recent extract file and open it.                                             *
'********************************************************************************************************
    'Set up filesys objects
    Set FileSys = New FileSystemObject
    Set myFolder = FileSys.GetFolder(extractsFolder)


    'Loop through each file and get file with date last modified. If largest date then store Filename
    dteFile = DateSerial(1900, 1, 1)
    For Each objFile In myFolder.Files
        If objFile.DateLastModified > dteFile Then
            dteFile = objFile.DateLastModified
            extractsFilename = objFile.Name
        End If
    Next objFile


    'Open File
    Workbooks.Open extractsFolder & extractsFilename


    Set FileSys = Nothing
    Set myFolder = Nothing


'********************************************************************************************************
'*  STEP 2 - Find the most recent Spec to Material Number Reference File and Store it for Reference     *
'********************************************************************************************************
    'Set up filesys objects
    Set FileSys = New FileSystemObject
    Set myFolder = FileSys.GetFolder(spectomatFolder)


    'Loop through each file and get date last modified. If largest date then store Filename
    dteFile = DateSerial(1900, 1, 1)
    For Each objFile In myFolder.Files
        If objFile.DateLastModified > dteFile Then
            dteFile = objFile.DateLastModified
            spectomatFilename = objFile.Name
        End If
    Next objFile


    Set FileSys = Nothing
    Set myFolder = Nothing


'********************************************************************************************************
'*  STEP 3 - Insert Material columns on all tabs of extract file and vlookup spec to mat reference file.*
'********************************************************************************************************
    Workbooks(extractsFilename).Activate
    Dim Col_num1 As Integer
    Dim Range1 As Range
    Dim i As Long


    'Select All Sheets of extract file and insert a new column called Material.
    ActiveWorkbook.Sheets.Select
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    Range("A1").Value = "Material" 'For some reason this only enters 'Material' on the first sheet.


    ActiveWorkbook.Sheets(1).Select 'Used to deselect all sheets


    For i = 1 To Sheets.Count
        ActiveWorkbook.Sheets(i).Select


        'Search for "Spec." Column header and record column number.
        Set Range1 = ActiveSheet.Range("1:1").Find("Spec.", , xlValues, xlWhole)
        Col_num1 = Range1.Column


        'Insert vlookup formula into first Cell, referencing the spec to material number file, and then remove vlookup
        Range("A2") = "=VLOOKUP(" & Chr(64 + Col_num1) & "2" & ",'" & spectomatFolder & "[" & spectomatFilename & "]Sheet1'!$A:$D,4,FALSE)"
        Range("A2").Select
        Selection.Copy
        Range("A2:A10000").Select
        ActiveSheet.Paste
        Range("A2:A10000").Select
        Selection.Copy
        Range("A2").Select
        ActiveSheet.Paste
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Next
    DoEvents


'********************************************************************************************************
'*  STEP 4. Create a new tab and generate a list of all unique material numbers included in the extract.*
'********************************************************************************************************
    Dim ThisnumSheets As Integer
    Dim ExtractsnumSheets As Integer
    Dim N As Double
    'Open this workbook (where the main data will be held.
    ThisWorkbook.Activate
    
    'Create a new tab. Funtion is below.
    AddSheets_TodayDate
    
    ThisnumSheets = Sheets.Count
    Sheets(ThisnumSheets).Select 'Selects last sheet (the newest sheet we just created)
          
    Workbooks(extractsFilename).Activate
    ExtractsnumSheets = Sheets.Count
    
    For i = 1 To ExtractsnumSheets
        Sheets(i).Range("A2:A10000").Copy
        ThisWorkbook.Activate
        Sheets(ThisnumSheets).Select
        N = 2 + ((i - 1) * 10000)
        Cells(N, 1).PasteSpecial xlValues 'pastes all values on next 10000 rows of column A.
        Workbooks(extractsFilename).Activate
    Next
    
    ThisWorkbook.Activate
    Sheets(ThisnumSheets).Select
              
    'Remove Duplicates
    Columns("A:A").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlNo


'********************************************************************************************************
'*  STEP 5. Vlookup all needed data from the extract into the new tab.                                  *
'********************************************************************************************************
    Dim columnHeaders As Variant
    Dim numcolumnHeaders As Integer
    Dim numofSKUs As Long
    
    'Update column header names here, note that vlookups in below code need to be ajusted if these change.
    columnHeaders = Array("Material", "Weight Target", "Weight UoM", "Width Target", "Width UoM", _
                    "Length Target", "Length UoM", "Shape", "Product Weight per package", _
                    "Portion Format", "Portions per Package")
    
    numcolumnHeaders = UBound(columnHeaders) - LBound(columnHeaders) + 1
    
    'Populate Column Headers
    For i = 1 To numcolumnHeaders
        Cells(1, i).Value = columnHeaders(i - 1) 'First array value is 0
    Next
    
    'These vlookups are specific to each column header.....if columns added or removed, all must be checked.
    Range("B2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]PortionWeight'!$A2:$Z10000,MATCH($B$1,'" & extractsFolder & "[" & extractsFilename & "]PortionWeight'!$A$1:$Z$1,0),FALSE)"
    Range("C2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]PortionWeight'!$A2:$Z10000,MATCH($C$1,'" & extractsFolder & "[" & extractsFilename & "]PortionWeight'!$A$1:$Z$1,0),FALSE)"
    Range("D2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]Width(Diameter)'!$A2:$Z10000,MATCH($D$1,'" & extractsFolder & "[" & extractsFilename & "]Width(Diameter)'!$A$1:$Z$1,0),FALSE)"
    Range("E2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]Width(Diameter)'!$A2:$Z10000,MATCH($E$1,'" & extractsFolder & "[" & extractsFilename & "]Width(Diameter)'!$A$1:$Z$1,0),FALSE)"
    Range("F2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]Length(SliceThickness)'!$A2:$Z10000,MATCH($F$1,'" & extractsFolder & "[" & extractsFilename & "]Length(SliceThickness)'!$A$1:$Z$1,0),FALSE)"
    Range("G2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]Length(SliceThickness)'!$A2:$Z10000,MATCH($G$1,'" & extractsFolder & "[" & extractsFilename & "]Length(SliceThickness)'!$A$1:$Z$1,0),FALSE)"
    Range("H2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]FoodFormat'!$A2:$Z10000,MATCH($H$1,'" & extractsFolder & "[" & extractsFilename & "]FoodFormat'!$A$1:$Z$1,0),FALSE)"
    Range("I2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]TotalFoodWeight'!$A2:$Z10000,MATCH($I$1,'" & extractsFolder & "[" & extractsFilename & "]TotalFoodWeight'!$A$1:$Z$1,0),FALSE)"
    Range("J2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]PortioningFormat'!$A2:$Z10000,MATCH($J$1,'" & extractsFolder & "[" & extractsFilename & "]PortioningFormat'!$A$1:$Z$1,0),FALSE)"
    Range("K2") = "=VLOOKUP(A2,'" & extractsFolder & "[" & extractsFilename & "]PortioningFormat'!$A2:$Z10000,MATCH($K$1,'" & extractsFolder & "[" & extractsFilename & "]PortioningFormat'!$A$1:$Z$1,0),FALSE)"
              
    'Copy formulas down, this must be updated if columns added or removed.
    numofSKUs = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count 'Count number of Skus in column A
    Range("B2:K2").Copy
    Range("B2:K" & numofSKUs + 5).Select
    ActiveSheet.Paste    'Paste formulas
    
    'Paste Values
    Range("B2:K" & numofSKUs + 5).Select
    Range("B2:K" & numofSKUs + 5).Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
            
    Sheets("Runme").Select
    Range("A1").Select


'********************************************************************************************************
'*  END OF LAST STEP                                                                                    *
'********************************************************************************************************
    DoEvents
    Workbooks(extractsFilename).Close Savechanges:=True
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
Sub AddSheets_TodayDate()
    Dim szTodayDate As String
    
'Need to add error checking to increment name if it already exists, incase macro is run more than once in a day
'Might look something like this:
'    For Each ws In Sheets
'        If ws.Name = "UNIQUE_DATA" Then ws.Delete
'    Next
    
    szTodayDate = Format(Date, "mmm-dd-yyyy")
    On Error GoTo MakeSheet
    Sheets(szTodayDate).Activate
    
    Exit Sub


MakeSheet:
    Sheets.Add , Worksheets(Worksheets.Count)
    ActiveSheet.Name = szTodayDate


End Sub

</update>

 

[yky]

Record time at the beginning of the first step and the end of each step to see which step is the longest.

It is known that Range.Find in a loop could take a long time. Follow the following link to use a Dictionary object (the first answer). I tried it on my case and it sped up things 30 times.

performance - VBA : Find function code - Stack Overflow

 

[footoo]

First step through the code via F8 to identify which parts of the code are taking a long time.
Then review these bits of code to see if there are faster ways.

 

[wiseone]

Hi thanks, now working through. In Step 3 I've eliminated all "activates" and "Selects" as well as limited the copy/pastes to the size of the data.

New Issue: BUT now after copying formula, all the vlookups are not calculating before it does copy/paste values......so some of the data is incorrect. I tried putting in the If application.calculationstate = xldone then doevents, but did not work.

I have 7 tabs this is being executed on, all have less than 700 rows, except one which has 8300 rows....thats the one where its not working.

Thoughts?

'********************************************************************************************************
'*  STEP 3 - Insert Material columns on all tabs of extract file and vlookup spec to mat reference file.*
'********************************************************************************************************
    Dim Col_num1 As Integer
    Dim Range1 As Range
    Dim i As Long
    Dim lastRow As Long
    
    For i = 1 To Sheets.Count
        With Workbooks(extractsFilename).Sheets(i)
             With ActiveSheet     'Checks if sheet filters are all cleared.  If yes, then do nothing.  Prevents error from popping up.
                If .FilterMode Then
                    .ShowAllData
                End If
             End With
            
            lastRow = .Range("A" & Rows.Count).End(xlUp).Row
            .Cells(1, 1).EntireColumn.Insert
            .Cells(1, 1).Value = "Material"


            'Search for "Spec." Column header and record column number.
            Set Range1 = .Range("1:1").Find("Spec.", , xlValues, xlWhole)
            Col_num1 = Range1.Column


            'Insert vlookup formula into first Cell, referencing the spec to material number file, and then remove vlookup
            .Range("A2") = "=VLOOKUP(" & Chr(64 + Col_num1) & "2" & ",'" & spectomatFolder & "[" & spectomatFilename & "]Sheet1'!$A:$D,4,FALSE)"
            .Range("A2").Copy .Range("A2:A" & lastRow)
            
            If Not Application.CalculationState = xlDone Then    'This If Statement lets the vlookup capture all values before copy/pasting values in next line.
                DoEvents
            End If
            
            'Copy Paste Values to eliminate vlookups
            .Range("A2:A" & lastRow).Value = .Range("A2:A" & lastRow).Value


        End With
    Next

 

[wiseone]

So i got my macro from 16 mins to 20 seconds by removing all instances of "Activate" and "Select". Also limiting copy/pastes to the number of rows required instead of a fixed 10000 rows. .....still struggling with the 8000 rows though mentioned on the previous comment......thoughts?

 

[pvr928]

Hi wiseone

Instead of copying a worksheet formula to the sheet, perform the calculation in an array, and then once the array has finished calculating, then print the result of the array to the worksheet.

This is an incredibly fast way of performing calculations and then displaying the results. They may be hard work initially to understand in concept and learn how to create, but over the long term, the results will pay off.

Have a look at this: The Complete Guide to Using Arrays in Excel VBA - Excel Macro Mastery

 

[wiseone]

Thanks, bookmarked that one!