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).

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.

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

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)

\$\begingroup\$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.\$\endgroup\$
– SquirrelApr 9 '18 at 18:29