I am trying to collate specific sheets with "Report" in their names across different excel files and paste them into a new excel document, with each new sheet's data pasted below the last used row of the collated sheet. I also need to check for any missing headers in the different excel files and add a header at the appropriate location if its missing. I have combined vba codes I have found online to first copy all the "Report" sheets of files in the directory to the consolidated excel file and then search for missing headers before copying the data to paste in Sheet1. However, I have some issues Firstly the missing columns are not added when I run the code. Next, I'm not too sure on how to write the via to do the copying and pasting in the first sheet's last used row as it is not working.
Sub AddMissingHeader()
Dim headers() As Variant
headers = Array("Report_Date", "Company", "Customer_Id", "Product_Id", "Company_Name")
Dim i As Long
For i = LBound(headers) To UBound(headers)
If Cells(5, i + 1).Value <> headers(i) Then
Columns(i + 1).EntireColumn.Insert
Cells(5, i + 1).Value = headers(i)
End If
Next i
End Sub
Sub SelectAndCopy()
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 2 To WS_Count
Worksheets(i).Select
Range("A3:M3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet1").Select
Dim lstrow As Integer 'finds the last row
lstrow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Range("A" & lstrow).Offset(1).Select
ActiveSheet.Paste
Next i
End Sub
Sub Collate()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = InputBox("Please copy and paste the path to the folder containing the source documents")
Set wbDst = ActiveWorkbook
strFilename = Dir(MyPath & "\*Report*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
For Each ws In wbSrc.Worksheets
If InStr(1, ws.Name, "New & Continuing", vbTextCompare) Then
Set wsSrc = ws
Call AddMissingHeader
End If
Next ws
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
Call SelectAndCopy
End Sub