VBA - 從不同的表中獲取具有相同標題的數據

這是我在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

來源

2016-09-14 Da Spotz

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

看起來你上面的代碼是在'General Data'工作簿中搜索'LIFNR'頭部名稱？然後找到最後一行和值？如果您知道標題和工作簿的名稱，並且它們永遠不會更改，請將一些參數添加到「DataGrab（param1，param2）」子例程中。例如，您可以編寫另一個調用DataGrab（param1，param2）的子例程，並使用變量來代替硬編碼的頭文件和文件名。 – CRUTER

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

來源

2016-09-14 18:55:17 Prakash

我已成功地實現我想要通過包含報頭的新片做限定的範圍映射。感謝您的有益建議，他們讓我走上了正軌！我選擇不將變量分配給標題名稱，因爲它使代碼更易於閱讀。以下是我對任何感興趣的人的完整工作代碼：

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

來源

2016-09-19 14:20:13

VBA - 從不同的表中獲取具有相同標題的數據

回答

相關問題