Pull together information from many workbooks based on headers

Question

I have written some code to pull together information from many workbooks in a specific folder on the network. It then grabs data from each sheet and puts them into a list, that is then used by a pivot table to display the data. The pulling of information into the workbook is running well enough however the finding and appending of the data once it has been pulled is taking an excessive amount of time. There are 3 subroutines that I have that appear to be using an excessive amount of time and was hoping I may get some advice on better functions or simply better ways to execute this to decrease my runtime.

Collect Data - This sub is what is used to pull the needed information from each sheet in the workbook. It is part of a loop that runs through each sheet. It is searching by header because the information I am given is not consistent enough to use columns or offsets.

' ---------------------------------------------- '
' Collect Data
' Search each sheet for the necessary columns
' ---------------------------------------------- '
Sub Collect_Data(intCurrentColumn As Integer)

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim CellRange As Range
Dim NextRow As Integer

Dim ThisSheet As Worksheet
Set ThisSheet = ThisWorkbook.ActiveSheet

'Search the Current Active Sheet
With ThisSheet

    'LC
    Set CellRange = .Rows(1).Find(What:="LC", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn)
    End If

    'Part Num
    Set CellRange = .Rows(1).Find(What:="Part Num", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 1)
    End If

    'Qty Shipped
    Set CellRange = .Rows(1).Find(What:="*Open Qty", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 2)
    End If

    'Estimated Ship Date
    Set CellRange = .Rows(1).Find(What:="Estimated Ship Date*", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not CellRange Is Nothing Then
        CellRange.EntireColumn.Copy Destination:=PartsWs.Columns(intCurrentColumn + 3)
    End If

End With

End Sub

Append Data - This sub appends the copied data from Collect Data to the end of the data in the first few columns to form the "list". (If this could somehow be combined into the Collect Data sub that would probably help, I simply couldn't figure out how to make sure it appended correctly.)

' ---------------------------------------------- '
' Append Data
' Pull each group of columns and append it to the end of the first group.
' ---------------------------------------------- '
Sub Append_Data(intCurrentColumn)

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim CopyRange As Range
Dim lngLastRow, lngLastPartsA As Long

'Get the last rows in column A and the column we are starting the range from
lngLastPartsA = PartsWs.Cells(Rows.Count, 1).End(xlUp).Row
lngLastRow = PartsWs.Cells(Rows.Count, intCurrentColumn).End(xlUp).Row

'Set range to copy
With PartsWs
    Set CopyRange = .Range(.Cells(2, intCurrentColumn), .Cells(lngLastRow, intCurrentColumn + 3))
End With

'Copy range after data already in Column A
CopyRange.Copy (PartsWs.Cells(lngLastPartsA + 1, 1))

End Sub

Lastly I have Clean Parts - This sub cleans up all excess columns in the Parts sheet, as well as doing some date calculations to simplify the data for the pivot table. This loops through every row (roughly 4k).

' ---------------------------------------------- '
' Clean Parts
' Clean up the Parts sheet, deleting excess columns/rows and doing date calculations for the Pivot Table
' ---------------------------------------------- '
Sub Clean_Parts()

Dim PartsWs As Worksheet
Set PartsWs = ThisWorkbook.Sheets(2)

Dim intCount As Integer
Dim lngColumnCount, lngLastRow As Long

PartsWs.Activate
lngColumnCount = PartsWs.Cells(1, Columns.Count).End(xlToLeft).Column

'Delete all excess Columns in sheet
PartsWs.Range(Cells(1, 5), Cells(1, lngColumnCount)).EntireColumn.Delete

lngLastRow = PartsWs.Cells(Rows.Count, 1).End(xlUp).Row

PartsWs.Cells(1, 5).Value = "Compiled Dates"

'Loop to check rows
For intCount = 2 To lngLastRow

    'If the Estimated Ship Date is blank, delete the row
    If IsEmpty(PartsWs.Cells(intCount, 4)) Then

        PartsWs.Rows(intCount).EntireRow.Delete
        intCount = intCount - 1
        lngLastRow = lngLastRow - 1
        If lngLastRow <= intCount Then

            Exit For

        End If

    'If Estimated Ship Date contains a valid date value, put the first day of the week 6 weeks later into column 5
    ElseIf IsDate(PartsWs.Cells(intCount, 4)) Then

        PartsWs.Cells(intCount, 5) = DateAdd("d", 1, DateAdd("ww", 6, DateValue(PartsWs.Cells(intCount, 4)) - Weekday(PartsWs.Cells(intCount, 4), vbMonday)))

    End If

Next intCount

End Sub

I do apologize if any of this is confusing or not done well, it has been a while since I've coded anything. Any new functions or simply any tips on how to make this run faster would be greatly appreciated. Between these 3 subs right now it's about 4 minutes.

Answer 1

The main changes I would make to the code

• Add Option Explicit at the top of every module - first line of defense
• Declare Subs as Public or Private - explicitly
  • Private Subs are not available outside their module (smaller scope)
• Sub Names should not use underscores because it can interfere with VBA events
  • Workbook_Open(), Worksheet_SelectionChange(), etc
• Define parameters explicitly ByVal or ByRef to clarify intent
  • ByVal sends a copy of the value (changes in current Sub will not affect calling Sub
  • ByRef sends a pointer to an object (changes in current Sub will be "seen" in caller)
• Define parameter types explicitly (Long, String, Variant, Range, Object, etc)
• To OP properly uses ThisWorkbook to work with the file where the code is executing
• Convert all Ints to Long, and drop Hungarian Notation (not useful)
• Keep consistent indentation, at proper levels

• Always fully qualify ranges. Statement below errors out if ActiveSheet is not PartsWS

  'Delete all excess Columns in sheet
   PartsWs.Range(Cells(1, 5), Cells(1, lngColumnCount)).EntireColumn.Delete
  

  Update to:

  PartsWs.Range(PartsWs.Cells(1,5),PartsWs.Cells(1,lngColumnCount)).EntireColumn.Delete .

• Copy with arrays (data only) instead of clipboard and with cell formatting (if not needed)

  • This is the most significant improvement in performance - top priority
• Converted For loop to delete rows with empty dates to AutoFilter
  • Deleting one row at the time is very slow, especially with many rows
  • The implementation of that For loop is quite convoluted
  • First rule to simplify deleting rows with loops is to move from the last row up

Other Notes

• Working with ActiveSheet should always be avoided
  • The sheet currently active on the screen may not be the intended one
    • Unless a user is forced to activate it, and not allowed to change it during runs
  • Replace it with the intended sheet, using the globally available Code Name (Sheet1)
  • Code Names cannot be easily edited by end-users, because they are accessible only through the VBA Editor (top-left corner, in the Project Explorer window), unlike the Tab Name which can be edited by double-clicking it, or the Tab Index that changes whenever tab order is changed by the user
• The code bellow is not tested

---

Option Explicit

Public Sub CollectData(ByVal partCol As Long)
    Dim partWs As Worksheet:    Set partWs = ThisWorkbook.Sheets(2)
    Dim thisWs As Worksheet:    Set thisWs = ThisWorkbook.ActiveSheet
    Dim lRow As Long, lCol As Long, hdr As Variant, c As Long, lrPart As Long
    Dim lc As Long, prt As Long, qty As Long, shp As Long, lch As String, arr As Variant

    lRow = thisWs.UsedRange.Rows.Count
    lCol = thisWs.Cells(1, Columns.Count).End(xlToLeft)
    hdr = thisWs.Range(thisWs.Cells(1, 1), thisWs.Cells(1, lCol))
    lrPart = partWs.UsedRange.Rows.Count

    For c = 1 To lCol
        lch = LCase(hdr(1, c))
        Select Case True
            Case lch = "lc":                            lc = c
            Case lch = "part num":                      prt = c
            Case InStr(lch, "open qty") > 0:            qty = c
            Case InStr(lch, "estimated ship date") > 0: shp = c
        End Select
    Next

    'Copy columns (data only, without cell formatting)
    partWs.Range(partWs.Cells(2, partCol), partWs.Cells(lrPart, partCol + 3)).Clear

    arr = thisWs.Range(thisWs.Cells(1, lc), thisWs.Cells(lRow, lc))
    partWs.Range(partWs.Cells(1, partCol + 0), partWs.Cells(lRow, partCol + 0)) = arr
    arr = thisWs.Range(thisWs.Cells(1, prt), thisWs.Cells(lRow, prt))
    partWs.Range(partWs.Cells(1, partCol + 1), partWs.Cells(lRow, partCol + 1)) = arr
    arr = thisWs.Range(thisWs.Cells(1, qty), thisWs.Cells(lRow, qty))
    partWs.Range(partWs.Cells(1, partCol + 2), partWs.Cells(lRow, partCol + 2)) = arr
    arr = thisWs.Range(thisWs.Cells(1, shp), thisWs.Cells(lRow, shp))
    partWs.Range(partWs.Cells(1, partCol + 3), partWs.Cells(lRow, partCol + 3)) = arr
End Sub

---

Public Sub AppendData(ByVal partCol As Long)
    Dim partsWs As Worksheet:   Set partsWs = ThisWorkbook.Sheets(2)

    Dim lrP, lrA As Long, arr As Variant

    lrA = partsWs.Cells(Rows.Count, 1).End(xlUp).Row        'Last Row in Column A
    lrP = partsWs.Cells(Rows.Count, partCol).End(xlUp).Row  'Last Row in Column partCol

    With partsWs  'Copy range after data in Column A (data only, without cell formatting)
        arr = .Range(.Cells(2, partCol), .Cells(lrP, partCol + 3))
        .Range(.Cells(lrA + 1, 1), .Cells(lrA + 1 + lrP, 4)) = arr
    End With
End Sub

---

Public Sub CleanParts()
    Const DT_COL = 4
    Dim partsWs As Worksheet:   Set partsWs = ThisWorkbook.Sheets(2)
    Dim i As Long, lc As Long, lr As Long, oldDt As Date, newDt As Date, arr As Variant

    lc = partsWs.Cells(1, Columns.Count).End(xlToLeft).Column
    lr = partsWs.Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Column A
    partsWs.Range(partsWs.Cells(1, DT_COL + 1), partsWs.Cells(1, lc)).EntireColumn.Delete
    'Delete rows with blank Estimated Ship Date - AutoFilter
    Application.ScreenUpdating = False: Application.EnableEvents = False
        With partsWs.UsedRange.Columns(DT_COL)
            .AutoFilter Field:=DT_COL, Criteria1:="<>"
            If .Columns(DT_COL).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                .Rows(1).Hidden = True
                .SpecialCells(xlCellTypeVisible).EntireRow.Delete
                .Rows(1).Hidden = False
            End If
            .AutoFilter
        End With
    Application.ScreenUpdating = True:  Application.EnableEvents = True

    'If Estimated Ship Date is valid date, put 1st day of week, 6 weeks later in col 5
    arr = partsWs.Range(partsWs.Cells(1, DT_COL), partsWs.Cells(lr, DT_COL + 1))
    For i = 2 To lr
        If Not IsError(arr(i, 1)) Then
            If IsDate(arr(i, 1)) Then
                oldDt = arr(i, 1)
                newDt = DateAdd("ww", 6, DateValue(oldDt) - Weekday(oldDt, vbMonday))
                arr(i, 2) = DateAdd("d", 1, newDt)
            End If
        End If
    Next
    partsWs.Range(partsWs.Cells(1, DT_COL), partsWs.Cells(lr, DT_COL + 1)) = arr
    partsWs.Cells(1, DT_COL + 1).Value = "Compiled Dates"
End Sub

---

A remark about files from the network

I consistently experienced very long delays getting data by opening the file from its network path (starting with "\\...")

The workaround was to first copy all files to a local path, open them locally and after a read-only operation, delete the local copy (much faster, and also eliminates the Read-Only warning because the file might be locked by another user)