问VBA中的索引匹配/vlookup
EN

Stack Overflow用户

提问于 2021-06-08 08:23:55

回答 2查看 334关注 0票数 0

我有一个Excel文档，它有两个不同的工作表。工作表2有列头名和行头名。Sheet 1中的一些列具有确切的标题名称和行头名称，但是它充满了数据。在这里输入图像描述，在这里输入图像描述

我想要创建一个宏，它将检查表1中的所有列/行标题，并在Sheet2中找到它们的对应匹配。当找到匹配时，我需要将工作表列/行标题的条目复制到sheet2的匹配头中。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

vba

match

vlookup

回答 2

Stack Overflow用户

回答已采纳

发布于 2021-06-08 08:41:19

最好的解决方案可以设置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

结果：

票数 0

Stack Overflow用户

发布于 2021-06-08 09:08:24

您可以使用内置的Range.Consolidate方法(https://learn.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