您的位置: 首页  >  技术问答  >  VBA - 从不同的表中获取具有相同标题的数据

VBA - 从不同的表中获取具有相同标题的数据

分类: 技术问答 • 2025-09-15 11:38:58
问题描述：

这是我在Stackoverflow上的第一个问题，虽然我一直在使用论坛一段时间，试图教自己的VBA。所以这里是我的第一个非常长的帖子：VBA - 从不同的表中获取具有相同标题的数据

我有一个包含工作表（一般数据）的工作簿（1），需要用包含工作表（sheet1）的其他工作簿（n）中的数据填充它。我想为此使用VBA，因为手动操作非常耗时且容易出错。 确定需要复制的数据的方式是通过标题（即LIFNR）。在工作表（常规数据）上，这些标题的位置和顺序可能会有所不同，并且在工作簿（n）.sheet1中标题的顺序可能会有所不同（尽管它们始终在第1行中）。

我已经成功地编写了一个工作代码，但它看起来像是一个Rube Goldberg机器......并且很乏味，因为我将有大约30个头文件和5个工作簿（n）来应用它。有没有更好更快的方式来实现我在做的事情？代码如下：

'Define the individual header names 
Sub DataGrab() 
Dim sdLIFNR, nLIFNR As Range 
Dim ws1, wsn As Worksheet 
Dim wb1, wbn As Workbook 
Dim fdn As FileDialog 
Dim data As String 
Dim LastCol1, LatRow1, LastColn, LastRown As Integer 

'Define worksheet(1) & worsheet(n) 
Set ws1 = ActiveWorkbook.Sheets("General Data") 

'Pick a file via file dialog 
Set fdn = Application.FileDialog(msoFileDialogFilePicker) 
With fdn 
.AllowMultiSelect = False 
.Title = "Please select the file containing the Bank data" 
.Filters.Clear 
If .Show = True Then 
data = fdn.SelectedItems(1) 
Else: GoTo CancelBox 
End If 
End With 

Set wbn = Workbooks.Open(data) 
Set wsn = wbn.Sheets("Sheet1") 


'Find last non empty column and row in sheet(general data) 

LastRow1 = ws1.Cells.Find(What:="*", _ 
       After:=Range("A1"), _ 
       LookAt:=xlPart, _ 
       LookIn:=xlFormulas, _ 
       SearchOrder:=xlByRows, _ 
       SearchDirection:=xlPrevious, _ 
       MatchCase:=False).Row 
LastCol1 = ws1.Cells.Find(What:="*", _ 
       After:=Range("A1"), _ 
       LookAt:=xlPart, _ 
       LookIn:=xlFormulas, _ 
       SearchOrder:=xlByColumns, _ 
       SearchDirection:=xlPrevious, _ 
       MatchCase:=False).Column 
'get position of where LIFNR is in sheet(n) 
wsn.Activate 
Set nLIFNR = wsn.Range("A1").EntireRow.Find("LIFNR", LookAt:=xlWhole) 

'get position of where LIFNR is in sheet(general data) 
ws1.Activate 
Set sdLIFNR = ws1.Range(Cells(1, 1), Cells(LastRow1, LastCol1)).Find("LIFNR", LookAt:=xlWhole) 

'Find lastrow in sheet(n) 
wsn.Activate 
LastRown = wsn.Cells(Rows.Count, nLIFNR.Column).End(xlUp).Row 

ws1.Range(ws1.Cells(LastRow1 + 1, sdLIFNR.Column), ws1.Cells(LastRow1 + LastRown - 1, sdLIFNR.Column)) = wsn.Range(wsn.Cells(2, nLIFNR.Column), wsn.Cells(LastRown, nLIFNR.Column)).Value 
Exit Sub 

CancelBox: 
MsgBox "You didn't select all the files required for this makro. Please restart this makro and try again" 

End Sub
+0

您使用的是哪个版本的Excel？ – user2676140

+0

看起来你上面的代码是在'General Data'工作簿中搜索'LIFNR'头部名称？然后找到最后一行和值？如果您知道标题和工作簿的名称，并且它们永远不会更改，请将一些参数添加到“DataGrab（param1，param2）”子例程中。例如，您可以编写另一个调用DataGrab（param1，param2）的子例程，并使用变量来代替硬编码的头文件和文件名。 – CRUTER

+0

我使用Excel 2016 @CRUTER使用变量而不是硬编码头文件名听起来像个好主意。我会试着找出一种方法来循环遍历我所拥有的代码，并在每次循环时更改变量。如果有人知道如何做到这一点，或者有一个有用的链接，我会很感激那个方向上的一个点 –

答

或者你可以在控制表的范围内提及标题名称并将它们定义为范围。稍后，您可以引用每个单元格值来获取标题名称，然后从标题行中查找每个单元格的名称。

'映射是一个范围在这里，一个是与范围内的名字关联的字符串变量。 Ey是一个范围。 “.COLUMN”函数将给报头字的列号RNG将存储相应的列字母等时d列数为4

锶列名 一个参考 C支线代码 ð账面余额 - 本地CCY 上述ë结束日期（日期值）

是在控制片材的两列

map = Range("Mapping") 

a = map(1, 2) ' here a will store the value reference 

basedata.Activate 'Its a workbook 
sheet.activate  ' Its a worksheet in basedata workbook  
Set Ey = basedata.ActiveSheet.Rows("1").Find(What:=a, LookIn:=xlValues,LookAt:=xlWhole) 
f1 = Ey.Column 

Cells(2, f1).Select 
Rng = ActiveCell.Address 
Rng = Replace(Rng, "2", "") 
Rng = Replace(Rng, "$", "")

答

我已成功地实现我想要通过包含报头的新片做限定的范围映射。感谢您的有益建议，他们让我走上了正轨！我选择不将变量分配给标题名称，因为它使代码更易于阅读。以下是我对任何感兴趣的人的完整工作代码：

Sub DataGrab() 
    Dim sdHEADER, nHEADER As Range 
    Dim wsData, wsCoCd, wsBank, wsContact, wsBankHeader, wsCoCdHeader, wsContactHeader, wsDataHeader, wsn As Worksheet 
    Dim wsBankn, wsCoCdn, wsContactn, wsDatan As Worksheet 
    Dim wb1, wbBankn, wbCoCdn, wbContactn, wbDatan As Workbook 
    Dim fdn As FileDialog 
    Dim PickFolder, Bankn, CoCdn, Contactn, Datan, HEADER As String 
    Dim LastCol1, LastRow1, LastRown, NrHeadBank, NrHeadCoCd, NrHeadContact, NrHeadData, i As Integer 

'Choose initial folder for file picker 
    PickFolder = "C:\" 

'Set up a file dialog to pick the files containing the data 
    Set fdn = Application.FileDialog(msoFileDialogFilePicker) 

'Activate file dialog and send to "CancelBox" if user presses cancel 

    With fdn 
    .AllowMultiSelect = False 
    .Title = "Please select the file containing the Bank data" 
    .Filters.Clear 
    .InitialFileName = PickFolder 
    If .Show = True Then 
    Bankn = fdn.SelectedItems(1) 
    With fdn 
     .AllowMultiSelect = False 
     .Title = "Please select the file containing the Company Code data" 
     .Filters.Clear 
     .InitialFileName = PickFolder 
     If .Show = True Then 
     CoCdn = fdn.SelectedItems(1) 
     With fdn 
      .AllowMultiSelect = False 
      .Title = "Please select the file containing the Contact data" 
      .Filters.Clear 
      .InitialFileName = PickFolder 
      If .Show = True Then 
      Contactn = fdn.SelectedItems(1) 
      With fdn 
       .AllowMultiSelect = False 
       .Title = "Please select the file containing the Report" 
       .Filters.Clear 
       .InitialFileName = PickFolder 
       If .Show = True Then 
       Datan = fdn.SelectedItems(1) 
       Else: GoTo CancelBox 
       End If 
      End With 
      Else: GoTo CancelBox 
      End If 
     End With 
     Else: GoTo CancelBox 
     End If 
    End With 
    Else: GoTo CancelBox 
    End If 
End With 
'Increase Makro Speed 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 

'Define worksheet(1) & worsheet(n) 
    Set wsData = ActiveWorkbook.Sheets("General Data") 
    Set wsBank = ActiveWorkbook.Sheets("Bank Data") 
    Set wsCoCd = ActiveWorkbook.Sheets("CoCd Data") 
    Set wsContact = ActiveWorkbook.Sheets("Contact Person") 

'Add Worksheets that contain the respective headers to the end of the workbook 
    With ThisWorkbook 
     Set wsBankHeader = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 
     wsBankHeader.name = "Bank Headers" 
     Set wsCoCdHeader = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 
     wsCoCdHeader.name = "CoCd Headers" 
     Set wsContactHeader = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 
     wsContactHeader.name = "Contact Headers" 
     Set wsDataHeader = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 
     wsDataHeader.name = "Data Headers" 
    End With 

'Fill the added worksheets with the required headers 
    With wsBankHeader 
     .Range("A1") = "LIFNR" 
     .Range("B1") = "KTOKK" 
     .Range("C1") = "NAME1" 
     .Range("D1") = "BANKS" 
     .Range("E1") = "BANKL" 
     .Range("F1") = "BANKN" 
     .Range("G1") = "BVTYP" 
     .Range("H1") = "IBAN" 
    End With 

    With wsCoCdHeader 
     .Range("A1") = "LIFNR" 
     .Range("B1") = "BUKRS" 
     .Range("C1") = "KTOKK" 
     .Range("D1") = "NAME1" 
     .Range("E1") = "AKONT" 
     .Range("F1") = "ZUAWA" 
     .Range("G1") = "FDGRV" 
     .Range("H1") = "FRGRP" 
     .Range("I1") = "ZTERM" 
     .Range("J1") = "REPRF" 
     .Range("K1") = "ZWELS" 
    End With 

    With wsContactHeader 
     .Range("A1") = "LIFNR" 
     .Range("B1") = "KTOKK" 
     .Range("C1") = "NAME1" 
     .Range("D1") = "NAMEV" 
     .Range("E1") = "NAME1_01" 
     .Range("F1") = "SMTP_ADDR" 
     .Range("G1") = "ABTNR" 
     .Range("H1") = "TEL_COUNTRY" 
     .Range("I1") = "TEL_NUMBER" 
     .Range("J1") = "FAX_COUNTRY" 
     .Range("K1") = "FAX_NUMBER" 
    End With 

    With wsDataHeader 
     .Range("A1") = "LIFNR" 
     .Range("B1") = "KTOKK" 
     .Range("C1") = "NAME1" 
     .Range("D1") = "NAME2" 
     .Range("E1") = "NAME3" 
     .Range("F1") = "SORTL" 
     .Range("G1") = "STRAS" 
     .Range("H1") = "PSTLZ" 
     .Range("I1") = "LAND1" 
     .Range("J1") = "SPRAS" 
     .Range("K1") = "TELF1" 
     .Range("L1") = "J_1KFTIND" 
    End With 



'Count number of columns in each Header sheet 
    NrHeadBank = wsBankHeader.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 

    NrHeadCoCd = wsCoCdHeader.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 

    NrHeadContact = wsContactHeader.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 
    NrHeadData = wsDataHeader.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 



'Define sheets in picked workbooks 
    Set wbBankn = Workbooks.Open(Bankn) 
    Set wsBankn = wbBankn.Sheets("Sheet1") 
    Set wbCoCdn = Workbooks.Open(CoCdn) 
    Set wsCoCdn = wbCoCdn.Sheets("Sheet1") 
    Set wbContactn = Workbooks.Open(Contactn) 
    Set wsContactn = wbContactn.Sheets("Sheet1") 
    Set wbDatan = Workbooks.Open(Datan) 
    Set wsDatan = wbDatan.Sheets("Sheet1") 

'Find last non empty column and row in sheets in wb1 
    LastRow1 = wsData.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row 
    LastCol1 = wsData.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 

    LastRow2 = wsContact.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row 
    LastCol2 = wsContact.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 

    LastRow3 = wsBank.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row 
    LastCol3 = wsBank.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 

    LastRow4 = wsCoCd.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row 
    LastCol4 = wsCoCd.Cells.Find(What:="*", _ 
        After:=Range("A1"), _ 
        LookAt:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Column 

'Fill sheet(General Data) with data from wbdata 
    For i = 1 To NrHeadData 
'Define what header to look for in every loop 
    '"Cells" has no automatic allocation, so always define ws when working with multiple wb & ws! 
     HEADER = wsDataHeader.Cells(1, i) 
'get position of where HEADER is in sheet(n) 
     wsDatan.Activate 'is required because of the way excel works 
     Set nHEADER = wsDatan.Range("A1").EntireRow.Find(HEADER, LookAt:=xlWhole) 
'Find lastrow in wsDatan 
     LastRown = wsDatan.Cells(Rows.Count, nHEADER.Column).End(xlUp).Row 
'get position of where HEADER is in 
     wsData.Activate 
     Set sdHEADER = wsData.Range(wsData.Cells(1, 1), wsData.Cells(LastRow1, LastCol1)).Find(HEADER, LookAt:=xlWhole) 
'Fill wsData 
     wsData.Range(wsData.Cells(LastRow1 + 1, sdHEADER.Column), wsData.Cells(LastRow1 + LastRown - 1, sdHEADER.Column)) = wsDatan.Range(wsDatan.Cells(2, nHEADER.Column), wsDatan.Cells(LastRown, nHEADER.Column)).Value 
    Next i 

'Fill sheet(General Data) with data from wbcontact 
    For i = 1 To NrHeadContact 
     HEADER = wsContactHeader.Cells(1, i) 
     wsContactn.Activate 
     Set nHEADER = wsContactn.Range("A1").EntireRow.Find(HEADER, LookAt:=xlWhole) 
     LastRown = wsContactn.Cells(Rows.Count, nHEADER.Column).End(xlUp).Row 
     wsContact.Activate 
     Set sdHEADER = wsContact.Range(wsContact.Cells(1, 1), wsContact.Cells(LastRow2, LastCol2)).Find(HEADER, LookAt:=xlWhole) 
     wsContact.Range(wsContact.Cells(LastRow2 + 1, sdHEADER.Column), wsContact.Cells(LastRow2 + LastRown - 1, sdHEADER.Column)) = wsContactn.Range(wsContactn.Cells(2, nHEADER.Column), wsContactn.Cells(LastRown, nHEADER.Column)).Value 
    Next i 

'Fill sheet(Bank) with data from wbbank 
    For i = 1 To NrHeadBank 
     HEADER = wsBankHeader.Cells(1, i) 
     wsBankn.Activate 
     Set nHEADER = wsBankn.Range("A1").EntireRow.Find(HEADER, LookAt:=xlWhole) 
     LastRown = wsBankn.Cells(Rows.Count, nHEADER.Column).End(xlUp).Row 
     wsBank.Activate 
     Set sdHEADER = wsBank.Range(wsBank.Cells(1, 1), wsBank.Cells(LastRow3, LastCol3)).Find(HEADER, LookAt:=xlWhole) 
     wsBank.Range(wsBank.Cells(LastRow3 + 1, sdHEADER.Column), wsBank.Cells(LastRow3 + LastRown - 1, sdHEADER.Column)) = wsBankn.Range(wsBankn.Cells(2, nHEADER.Column), wsBankn.Cells(LastRown, nHEADER.Column)).Value 
    Next i 

'Fill sheet(CoCd) with data from wbCoCd 
    For i = 1 To NrHeadCoCd 
     HEADER = wsCoCdHeader.Cells(1, i) 
     wsCoCdn.Activate 
     Set nHEADER = wsCoCdn.Range("A1").EntireRow.Find(HEADER, LookAt:=xlWhole) 
     LastRown = wsCoCdn.Cells(Rows.Count, nHEADER.Column).End(xlUp).Row 
     wsCoCd.Activate 
     Set sdHEADER = wsCoCd.Range(wsCoCd.Cells(1, 1), wsCoCd.Cells(LastRow4, LastCol4)).Find(HEADER, LookAt:=xlWhole) 
     wsCoCd.Range(wsCoCd.Cells(LastRow4 + 1, sdHEADER.Column), wsCoCd.Cells(LastRow4 + LastRown - 1, sdHEADER.Column)) = wsBankn.Range(wsBankn.Cells(2, nHEADER.Column), wsBankn.Cells(LastRown, nHEADER.Column)).Value 
    Next i 

'Delete the Header Sheets that were added, close opened workbooks and reset sheet settings 
    Application.DisplayAlerts = False 
    wsBankHeader.Delete 
    wsCoCdHeader.Delete 
    wsContactHeader.Delete 
    wsDataHeader.Delete 
    Application.DisplayAlerts = True 
    wbBankn.Close 
    wbCoCdn.Close 
    wbContactn.Close 
    wbDatan.Close 
    Application.EnableEvents = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 
    Exit Sub 

CancelBox: 
    MsgBox "You didn't select all the files required for this makro. Please restart this makro and try again" 

    End Sub

相关推荐