Hello, I'm self-taught with VBA coding and always looking to learn. I wrote this macro which finally works. I've done some of the basic tips for optimization, but I'm wondering if anyone has any additional suggestions for making it faster. It is possible that the macro has to open and close nearly 450 files to retrieve the data, although most of the time it has less to open and close. I have several notes in the code to myself (sorry). Please note that the macro has to work on Excel 2016 and 2013. Any help is appreciated:
Code:
Sub Promise_Date_Change_Detector()
'Turn off screen updating once macro is complete to speed up processing time
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Dim WB As Workbook
Dim WS As Worksheet
Dim c As Integer
Dim StrtFile As Variant
Dim fso As New Scripting.FileSystemObject
Dim ian As String
Dim fileSpec As File
Dim strInfo As String
Dim wsLR As Long
Set fldr = fso.GetFolder("U:\Public\All Customer Reports\All Customers Report 2018")
'Label Column Headers , "PO#", "Sales Order", "Line #", "Promise Date","file date"
Cells(5, 1).Value = "PO#"
Cells(5, 2).Value = "Sales Order"
Cells(5, 3).Value = "Line #"
Cells(5, 4).Value = "Promise Date"
Cells(5, 5).Value = "Customer Order File"
'Build Input Box to Inquire as to PO in Question
PurchaseOrder = InputBox("What PO would you like information for?", "PO#?")
'Find Order Date in Latest file
'Retrieve file path of latest file from this workbook
Lfile = Worksheets(1).Cells(2, 6).Value
Workbooks.Open Filename:=Lfile, ReadOnly:=True
'Loop through the rows in latest file to find order date
k = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For datfind = 2 To k
If Worksheets(1).Cells(datfind, 2).Value = PurchaseOrder Then
N = Worksheets(1).Cells(datfind, 14).Value
End If
Next datfind
'reformat the date to match the file names
N = Format(N, "mm-dd-yyyy")
'create the starting file file path
' Original statement doesn't work with Excel 2013
' StrtFile = Application.WorksheetFunction.Concat(fldr, "", N, " am", ".xls")
'
' This statement works
'
StrtFile = N & " am.xls"
'Loop through all the files in the customers report folder and pull out the po info
'find current bottom row of this work book
x = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
'Set up a counter for the number of files in the folder
countfile = 0
For Each wbfile In fldr.Files
countfile = countfile + 1
Next wbfile
'Determine the number of the file in question with respect to the total number of files
howmany = 0
For Each wbfile In fldr.Files
howmany = howmany + 1
If wbfile.Name = StrtFile Then
J = howmany
End If
Next wbfile
'Loop from starting file to the last file searching for the PO data and copy/paste that data to this workbook
c = 0
Z = 6
For Each wbfile In fldr.Files
c = c + 1
If c >= J Then
If c <= countfile - 1 Then
Application.EnableEvents = False
Set fileSpec = fso.GetFile(wbfile)
ian = fileSpec.Name
ian = fldr & "" & ian
If fso.GetExtensionName(ian) = "xls" Then
Workbooks.Open Filename:=ian, ReadOnly:=True
Set WS = Worksheets(1)
Sheets("Foglio1").Activate
With ActiveSheet
wsLR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
End With
For Y = 2 To wsLR
If WS.Cells(Y, 2).Value = PurchaseOrder Then
WS.Cells(Y, 2).Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Z, 1)
WS.Cells(Y, 3).Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Z, 2)
WS.Cells(Y, 4).Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Z, 3)
WS.Cells(Y, 21).Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Z, 4)
ThisWorkbook.Worksheets(1).Cells(Z, 5) = ian
Z = Z + 1
End If
Next Y
ActiveWorkbook.Close
End If
End If
End If
Application.EnableEvents = True
Next wbfile
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
End Sub
Last edited by a moderator:
