Question

这是我关于Stackoverflow的第一个问题，虽然我已经使用论坛一段时间了，试图自学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

Answer 1

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

'mapping是此处的范围，a是与范围中的第一个名称关联的字符串变量。 Ey是一个范围。 '.column'函数将给出标题字Rng的列号，当列号为4时，将存储相应的列字母，如D

高级专栏名称参考 c分行代码 d账面余额 - 本地CCY e结束日期（价值日期）

上面的

是在两列控制表

中定义的范围映射

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, "$", "")

Answer 2

我已经设法通过包含标题的新工作表实现我想要做的事情。感谢您的有用建议，他们让我走上正轨！我选择不将变量分配给Header名称，因为它使代码更容易阅读。以下是我对以下任何感兴趣的人的完整工作代码：

    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

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

2 个答案: