VBA 中的索引匹配匹配/查找 [英] Index match match/vlookup in VBA

问题描述

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

I have an Excel document with two different Sheets. Sheet 2 has columns header names and rows header names. Sheet 1 has some of these columns with exact header names and rows header names but it's filled with data. enter image description here, enter image description here

I want to make a macro that will look through all the column/rows headers in Sheet 1 and find their corresponding match in Sheet2. When the match is found, I need to copy the entry of the Sheet column/row header into the matching header of sheet2. Some entries in Sheet2 will not have matches and will remain blank. I want it to look like this: enter image description here

This is my code so far, it is working for the column headers but I don't know how to add for row headers as well. Any help is welcomed :)

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

解决方案

Your best solution might to set 2 ranges, each taking values from tables in Sheet1 and Sheet2. Let's call them rgSrcTable and rgDestTable. Then you need to loop using For Each through each range and compare top and left headers, and when you find a match, copy the value of the cell in rgSrcTable to the cell in rgDestTable.

Edit: Code sample. Feel free to adapt ranges to your needs. Since this routine used Range.Value property, you can filter any data (string, numbers, etc.)

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

Result:

这篇关于VBA 中的索引匹配匹配/查找的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！