Sub Consolidate() Dim fName As String, fPath As String, fPathDone As String Dim LR As Long, NR As Long Dim wbData As Workbook, ws As Worksheet 'Setup Application.ScreenUpdating = False 'speed up macro execution Application.EnableEvents = False 'turn off other macros for now Application.DisplayAlerts = False 'turn off system messages for now Set ws = ThisWorkbook.Sheets("sheet5") 'sheet report is built into With ws If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then .UsedRange.Offset(1).EntireRow.Clear NR = 2 Else NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data End If 'Path and filename (edit this section to suit) fPath = "C:\Users\" 'remember final \ in this string fPathDone = fPath & " Validation\" 'remember final \ in this string On Error Resume Next MkDir fPathDone 'creates the completed folder if missing On Error GoTo 0 fName = Dir(fPath & "*.xls*") 'listing of desired files, edit filter as desired 'Import a sheet from found files For Each ws In wbData.Sheets(Array(" Component List", " Component", "Components")) LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row 'Find last row If NR = 1 Then 'copy the data AND titles ws.Range("A1:A" & LR).EntireRow.Copy .Range("A" & NR) Else 'copy the data only ws.Range("A2:A" & LR).EntireRow.Copy .Range("A" & NR) End If NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row Next ws End With ErrorExit: 'Cleanup ActiveSheet.Columns.AutoFit Application.DisplayAlerts = True 'turn system alerts back on Application.EnableEvents = True 'turn other macros back on Application.ScreenUpdating = True 'refreshes the screen End Sub
Set ws = ThisWorkbook.Sheets("sheet5") 'sheet report is built into With ws
var
This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)