# Pull together information from many workbooks based on headers

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.

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)

• Thank you for taking all that time to reply. Literally just implementing the changes to the first sub already made a world of difference so i'm sure the others will as well. As far as the network thing goes, i'm actually copying the first sheet from each workbook in a specific folder into this workbook and then basing everything else off the local data so it isn't too much of an issue. The initial copy only takes 20-30 seconds. I also appreciate all the tips, as I said it's been a while since I've done any programming so I'm a bit out of touch. – Squirrel Apr 9 '18 at 18:29