VBA - 別のシートから同じヘッダーを持つデータを取得する

Question

これは私がVBAを教えようとしている間、フォーラムをしばらく使用していましたが、これはStackoverflowに関する私の最初の質問です。

ワークシート（一般データ）を含むワークブックがあり、シート（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

コントロールシートの範囲内のヘッダー名を指定して範囲として定義できます。後で各セルの値を参照してヘッダー名を取得し、ヘッダー行の各セルを調べることができます。

'ここでのマッピングは範囲であり、aはrangeの最初の名前に関連付けられた文字列変数です。 Eyは範囲です。ローカルCCY - 「.column」関数は、列数が4

Srの列名 帳バランスdは参照 C支店コードである場合、RNGは、Dのような対応する列のアルファベットを格納するヘッダワードの列番号を与えます電子終了日（バリュー日）

は、上記の私はヘッダーが含まれている新しいシートでやりたいことを達成するために管理している

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

制御シートの2列に定義された範囲のマッピングです。あなたの有益な提案をありがとう、彼らは正しい軌道に私を得た！ヘッダー名に変数を割り当てないようにしたのは、コードを読みやすくしたからです。興味のある方は下記の完全な作業コードをお読みください。

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