VBA 中的索引匹配 match/vlookup

Question

我有一个包含两个不同 Sheet 的 Excel 文档。 Sheet 2 有列 header 个名称和行 header 个名称。 Sheet 1 中的某些列具有确切的 header 名称和行 header 名称，但其中充满了数据。 enter image description here, enter image description here

我想制作一个宏来查看 Sheet 1 中的所有 column/rows header 并在 Sheet2 中找到它们的对应匹配项。找到匹配后，我需要将Sheet column/row header 的条目复制到sheet2 的匹配header 中。 Sheet2 中的某些条目将没有匹配项，因此将保持空白。我希望它看起来像这样： enter image description here

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

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 遍历每个范围并比较顶部和左侧 headers，当你找到匹配时，将 rgSrcTable 中单元格的值复制到 [= 中的单元格12=].

编辑：代码示例。随意根据您的需要调整范围。由于这个例程使用了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:$E")
        Set rngDest = .Worksheets("shtDest").Range("$B:$E")
        
        ' 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)： (编辑2)

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

VBA 中的索引匹配 match/vlookup

Index match match/vlookup in VBA

vba

match

vlookup