I am looking to consolidate data from multiple worksheets and Workbooks with different column headers into single worksheet name (Database) using vba. Currently I have the below code that opens two workbooks and copies the sheets to the destination workbook. Then currently (Database sheet) in the destination workbook has fixed headers which are then matched with headers in all the copied sheets and then copies all the row data and pastes into Database sheet for the respective column header.

Sub CopySheetFromClosedWB()
Application.ScreenUpdating = False
Dim closedBook1 As Workbook
Dim closedBook2 As Workbook

    Set closedBook1 = Workbooks.Open("C:\New folder\Exec_072021.xlsb", Password:="**********")
    Set closedBook2 = Workbooks.Open("C:\New folder\Non Exec_072021.xlsb", Password:="**********")
    
    Dim ws1 As Worksheet
    For Each ws1 In closedBook1.Sheets
        ws1.Copy After:=ThisWorkbook.Sheets(3)
        ActiveSheet.Name = ActiveSheet.Name & "_Exec"
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
    Next ws1
    closedBook1.Close SaveChanges:=False
     
    Dim ws2 As Worksheet
    For Each ws2 In closedBook2.Sheets
         ws2.Copy After:=ThisWorkbook.Sheets(3)
         ActiveSheet.Name = ActiveSheet.Name & "_NonExec"
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
    Next ws2
    closedBook2.Close SaveChanges:=False
     
    Call UpDateData
    MsgBox "Database Created!!"

        
    Application.ScreenUpdating = True

End Sub

Sub UpDateData()
Application.ScreenUpdating = False

 Dim i As Long, j As Long, k As Long, n As Long, wData As Worksheet, _
    Process(1 To 10) As String, iProc As Long, Dict As Object
    Process(1) = "Manila_Exec"
    Process(2) = "Cebu_Exec"
    Process(3) = "Davao_Exec"
    Process(4) = "CDO_Exec"
    Process(5) = "Bacolod_Exec"
    Process(6) = "Manila_NonExec"
    Process(7) = "Cebu_NonExec"
    Process(8) = "Davao_NonExec"
    Process(9) = "CDO_NonExec"
    Process(10) = "Bacolod_NonExec"
    Set wData = Sheets("Database")
    Set Dict = CreateObject("Scripting.Dictionary")
    With wData
    .UsedRange.Offset(1).Clear
    For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
    If Len(.Cells(1, j)) > 0 Then Dict.Add LCase$(.Cells(1, j)), j
    Next j
    End With
    i = 2
    For iProc = 1 To 10
    With Sheets(Process(iProc))
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
    If Dict.exists(LCase$(.Cells(1, j))) Then
    k = Dict(LCase$(.Cells(1, j)))
    .Cells(2, j).Resize(n - 1).Copy wData.Cells(i, k).Resize(n - 1)
    End If
    Next j
    End With
        i = i   n - 1
    Next iProc
 
    Sheets("Database").Select
    Selection.CurrentRegion.Select
    Selection.CurrentRegion.Font.Size = 9
    Selection.CurrentRegion.Font.Name = "Calibri"
    Selection.CurrentRegion.Borders.LineStyle = x1None
    For x = 1 To ActiveSheet.UsedRange.Columns.Count
    Columns(x).EntireColumn.AutoFit
    Next x
       
    
    
 End Sub

I am trying to make a code that can eliminate the dependency of moving the sheets from multiple workbooks to destination workbook and copy values along with header names for all the matched and unmatched column headers.

Headers are in row 1 in all the worksheets.
Total rows - 50000
Total columns - 170

CodePudding user response：

Tested, and working for me.

EDIT: made a bunch of fixes.

Sub ProcessWorkbooks()
    
    Dim f, wsData As Worksheet, wbSrc As Workbook, map As Object
    
    Set wsData = ThisWorkbook.Sheets("Data")
    wsData.UsedRange.ClearContents 'clear any existing data
    
    Set wbSrc = Workbooks.Open("C:\New folder\Exec_072021.xlsb", Password:="**********")
    ImportData wbSrc, wsData
    wbSrc.Close False
    
    Set wbSrc = Workbooks.Open("C:\New folder\Non Exec_072021.xlsb", Password:="**********")
    ImportData wbSrc, wsData
    wbSrc.Close False
    
    With wsData.Range("A1").CurrentRegion
        .Font.Size = 9
        .Font.Name = "Calibri"
        .Borders.LineStyle = xlLineStyleNone
        .EntireColumn.AutoFit
    End With

End Sub

Sub ImportData(wbIn As Workbook, wsData As Worksheet)
    
    Dim lrData As Long, lrSrc As Long, ws As Worksheet, c As Range
    Dim Process, hdr, m
    
    
    Process = Array("Manila", "Cebu", "Davao", "CDO", "Bacolod")
    Application.ScreenUpdating = False
    
    For Each ws In wbIn.Worksheets
        If Not IsError(Application.Match(ws.Name, Process, 0)) Then 'process this sheet?
            lrData = SheetLastRow(wsData)   1
            If lrData = 1 Then lrData = 2 'in case no headers yet...
            lrSrc = SheetLastRow(ws)
            For Each c In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
                hdr = c.Value
                
                m = Application.Match(hdr, wsData.Rows(1), 0) 'existing column match?
                If IsError(m) Then
                    m = Application.CountA(wsData.Rows(1))
                    m = IIf(m = 0, 1, m   1)
                    wsData.Cells(1, m).Value = hdr 'add as new column header
                End If
                
                ws.Range(c.Offset(1), ws.Cells(lrSrc, c.Column)).Copy _
                        wsData.Cells(lrData, m)
            Next c
        End If
    Next ws
End Sub

'return the last used row in a worksheet
Function SheetLastRow(ws As Worksheet) As Long
    Dim f As Range
    Set f = ws.Cells.Find("*", ws.Range("A1"), xlFormulas, xlPart, xlByRows, xlPrevious)
    If Not f Is Nothing Then SheetLastRow = f.Row 'otherwise 0
End Function