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