VBA中的索引匹配匹配/vlookup

Question

我有一个包含两个不同工作表的 Excel 文档。工作表 2 具有列标题名称和行标题名称。工作表 1 有一些列具有准确的标题名称和行标题名称，但它填充了数据。 enter image description here, enter image description here

我想创建一个宏，它会查看工作表 1 中的所有列/行标题，并在工作表 2 中找到它们对应的匹配项。找到匹配项后，我需要将 Sheet 列/行标题的条目复制到 sheet2 的匹配标题中。 Sheet2 中的某些条目将没有匹配项，并且将保持空白。 我希望它看起来像这样： enter image description here

到目前为止，这是我的代码，它适用于列标题，但我也不知道如何添加行标题。欢迎任何帮助:)

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

您最好的解决方案可能是设置 2 个范围，每个范围从 Sheet1 和 Sheet2 中的表中获取值。我们称他们为rgSrcTable 和rgDestTable。然后你需要使用For Each循环遍历每个范围并比较顶部和左侧标题，当你找到匹配时，将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

结果：

Answer 2

您可以使用内置的 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