Блог

Я хочу объединить данные из нескольких листов и книг с разными заголовками столбцов в одно имя листа (база данных) с помощью vba. В настоящее время у меня есть приведенный ниже код, который открывает две книги и копирует листы в целевую книгу. Затем в настоящее время (лист базы данных) в целевой книге есть фиксированные заголовки, которые затем сопоставляются с заголовками на всех скопированных листах, а затем копируются все данные строк и вставляются в лист базы данных для соответствующего заголовка столбца.

 Sub CopySheetFromClosedWB() Application.ScreenUpdating = False Dim closedBook1 As Workbook Dim closedBook2 As Workbook   Set closedBook1 = Workbooks.Open("C:New folderExec_072021.xlsb", Password:="**********")  Set closedBook2 = Workbooks.Open("C:New folderNon Exec_072021.xlsb", Password:="**********")    Dim ws1 As Worksheet  For Each ws1 In closedBook1.Sheets  ws1.Copy After:=ThisWorkbook.Sheets(3)  ActiveSheet.Name = ActiveSheet.Name amp; "_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 amp; "_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)) gt; 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   

Я пытаюсь создать код, который может устранить зависимость перемещения листов из нескольких книг в целевую книгу и скопировать значения вместе с именами заголовков для всех совпадающих и несопоставимых заголовков столбцов.

Заголовки находятся в строке 1 во всех рабочих листах.
Всего строк — 50000
Всего столбцов — 170

Проверено и работает на меня.

ПРАВКА: внесено множество исправлений.

 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 folderExec_072021.xlsb", Password:="**********")  ImportData wbSrc, wsData  wbSrc.Close False    Set wbSrc = Workbooks.Open("C:New folderNon 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