Excel中使用VBA进行数据匹配并复制相应行到另一个表

Sub MatchAndCopyData()

' 定义工作簿和工作表对象

    Dim wb As Workbook

    Set wb = ThisWorkbook ' 使用当前工作簿，或指定具体路径 Set wb = Workbooks.Open("D:\exlsx\file.xlsx")

   

    ' 定义表1、表2和表3工作表对象

    Dim wsSource As Worksheet, wsMatch As Worksheet, wsTarget As Worksheet

    Set wsSource = wb.Sheets("Sheet1") ' 表1的名称 源数据表

    Set wsMatch = wb.Sheets("Sheet2") ' 表2的名称  匹配数据表

    Set wsTarget = wb.Sheets("Sheet3") ' 表3的名称 目的数据表

   

    ' 初始化变量

    Dim iRowSrc As Long, iRowMatch As Long, iRowTgt As Long

    iRowSrc = 2 ' 表1数据起始行（假设第一行为表头）

    iRowMatch = 1 ' 表2数据起始行（假设无表头）

    iRowTgt = 2 ' 表3数据起始行（假设第一行为表头）

   

    ' 循环遍历表2数据

    While wsMatch.Cells(iRowMatch, 1).Value <> "" ' 假设以A列非空判断是否有数据

        

        ' 从表1查找匹配项

        Dim matchFound As Boolean: matchFound = False

        Dim matchRow As Long

        For iRowSrc = 2 To wsSource.Rows.Count ' 循环表1数据行

            If wsSource.Cells(iRowSrc, 2).Value = wsMatch.Cells(iRowMatch, 1).Value Then ' 假设以匹配数据A列匹配数据源表的B列

                matchFound = True

                matchRow = iRowSrc

                ' 复制匹配到的表1数据行到表3               

                wsSource.Rows(matchRow).Copy Destination:=wsTarget.Rows(iRowTgt)

                iRowTgt = iRowTgt + 1 ' 更新目标表的下一行  

                iRowMatch = iRowMatch + 1 ' 移动到表2的下一行

            End If

        Next iRowSrc      

        

    Wend   

    MsgBox "匹配并复制数据完成！"

End sub