VBA 中的索引匹配匹配/vlookup

Question

我有一個包含兩個不同工作表的 Excel 文檔。 工作表 2 具有列 header 名稱和行 header 名稱。 表 1 有一些列具有精確的 header 名稱和行 header 名稱，但它填充了數據。 在此處輸入圖像描述，在此處輸入圖像描述

我想制作一個宏，它將查看工作表 1 中的所有列/行標題，並在工作表 2 中找到它們對應的匹配項。 找到匹配項后，我需要將 Sheet 列/行 header 的條目復制到 sheet2 的匹配 header 中。 Sheet2 中的某些條目將沒有匹配項，並且將保持空白。 我希望它看起來像這樣：在此處輸入圖像描述

到目前為止，這是我的代碼，它適用於列標題，但我也不知道如何添加行標題。 歡迎任何幫助:)

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = desWS.Cells(3, Columns.Count).End(xlToLeft).Column
    For Each header In desWS.Range(desWS.Cells(3, 2), desWS.Cells(3, lCol))
        Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(3, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(4, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Answer 1

您可以使用內置 Range.Consolidate 方法（ https://docs.microsoft.com/en-us/office/vba/api/excel.range.consolidate ）：（ Edit2 ）

Option Explicit

Sub ConsolidateThis()
    Dim rng1 As Range, rng2 As Range, addr As String
    With ThisWorkbook
        ' determine source and destination ranges
        Set rng1 = getTableRange(.Worksheets("Sheet1").Range("A2"))
        Set rng2 = getTableRange(.Worksheets("Sheet2").Range("A3"))
        
        ' make full address of consolidated range like "'[Consolidate.xlsm]Sheet1'!R3C1:R6C5"
        addr = "'[" & .Name & "]" & rng1.Parent.Name & "'!" & rng1.Address(ReferenceStyle:=xlR1C1)
        
        ' do consolidation
        rng2.Consolidate Sources:=Array(addr), Function:=xlSum, TopRow:=True, LeftColumn:=True
    End With
End Sub

' Returns the range that starts with the top left corner cell and is bounded
' on the right and bottom by empty cells
Function getTableRange(LeftTopCornerCell As Range) As Range
    Dim ws As Worksheet, rightEdge As Long, downEdge As Long
    With LeftTopCornerCell(1)
        Set ws = .Parent
        rightEdge = ws.Cells(.Row, ws.Columns.Count).End(xlToLeft).Column
        downEdge = ws.Cells(ws.Rows.Count, .Column).End(xlUp).Row
    End With
    Set getTableRange = ws.Range(LeftTopCornerCell(1), ws.Cells(downEdge, rightEdge))
End Function

Answer 2

您最好的解決方案可能是設置 2 個范圍，每個范圍從 Sheet1 和 Sheet2 中的表中獲取值。 我們稱它們為rgSrcTable和rgDestTable 。 然后，您需要使用For Each循環遍歷每個范圍並比較頂部和左側標題，當您找到匹配項時，將 rgSrcTable 中單元格的值復制到rgSrcTable中的單元rgDestTable 。

編輯：代碼示例。 隨意調整范圍以滿足您的需求。 由於此例程使用Range.Value屬性，您可以過濾任何數據（字符串、數字等）

Option Explicit

Sub CopyDataWithFilter()
    Dim iRowHeader As Integer, iColHeader As Integer
    Dim rngSrc As Range, rngDest As Range, celSrc As Range, celDest As Range
    
    iRowHeader = 2
    iColHeader = 1
    With ThisWorkbook
        ' Set source and destination ranges. Modify ranges according to your needs
        Set rngSrc = .Worksheets("shtSrc").Range("$B$3:$E$5")
        Set rngDest = .Worksheets("shtDest").Range("$B$3:$E$5")
        
        ' Loop through source range and dest range
        For Each celDest In rngDest
            For Each celSrc In rngSrc
            
                ' Compare top headers and left headers respectively. If matching, copy the value in destination table.
                If .Worksheets("shtSrc").Cells(celSrc.Row, iColHeader).Value = .Worksheets("shtDest").Cells(celDest.Row, iColHeader).Value And _
                   .Worksheets("shtSrc").Cells(iRowHeader, celSrc.Column).Value = .Worksheets("shtDest").Cells(iRowHeader, celDest.Column).Value Then
                   celDest.Value = celSrc.Value
                End If
            Next celSrc
        Next celDest
    End With
End Sub

結果：