VBA按列部分匹配提取数据并填充目标工作表问题求助

以下是符合需求的VBA代码，全程使用Range.Value赋值替代复制粘贴操作，代码包含详细注释：

Sub FillNewSheetData()
    ' 声明变量
    Dim wbTemplate As Workbook, wbProcess As Workbook, wbCR As Workbook, wbDQM As Workbook
    Dim wsNew As Worksheet, wsCR As Worksheet, wsDQM As Worksheet
    Dim tabName As String
    Dim lastRowCR As Long, lastRowNewCR As Long, lastRowDQM As Long
    Dim i As Long, j As Long
    Dim dqmHeaders As Variant, dqmTargetCols As Variant
    
    ' 绑定已打开的工作簿（若未打开，可添加Workbooks.Open("文件路径")代码）
    Set wbTemplate = Workbooks("Template.xlsx") ' 替换为实际文件名
    Set wbProcess = Workbooks("Process.xlsx")
    Set wbCR = Workbooks("CR.xlsx")
    Set wbDQM = Workbooks("DQM.xlsx")
    
    ' 绑定对应工作表
    Set wsCR = wbCR.Worksheets("CR")
    Set wsDQM = wbDQM.Worksheets("DQM")
    
    ' --------------------------
    ' 遍历Template中已创建的NewSheet
    ' --------------------------
    For Each wsNew In wbTemplate.Worksheets
        ' 跳过模板本身（替换为你的模板工作表名）
        If wsNew.Name <> "TemplateSheet" Then
            tabName = wsNew.Range("B4").Value ' 获取当前工作表对应的TabName
            
            ' ======================
            ' 1. 从CR工作簿提取匹配行并填充到E5开始位置
            ' ======================
            lastRowCR = wsCR.Cells(Rows.Count, "A").End(xlUp).Row ' 假设SORID在A列，替换为实际列号
            ' 筛选包含tabName的行
            For i = 2 To lastRowCR ' 假设第1行为表头
                If InStr(1, wsCR.Cells(i, "A").Value, tabName, vbTextCompare) > 0 Then ' 忽略大小写匹配
                    ' 定位NewSheet中CR数据的最后行
                    lastRowNewCR = wsNew.Cells(Rows.Count, "E").End(xlUp).Row
                    If lastRowNewCR < 5 Then lastRowNewCR = 4 ' 确保从E5开始填充
                    ' 整行赋值（假设CR表数据范围是A到D列，可按需调整）
                    wsNew.Range("E" & lastRowNewCR + 1 & ":" & "H" & lastRowNewCR + 1).Value = _
                        wsCR.Range("A" & i & ":" & "D" & i).Value
                End If
            Next i
            
            ' ======================
            ' 2. 从DQM工作簿提取匹配行并填充到CR数据下方第5行
            ' ======================
            ' 获取CR数据填充后的最后行
            lastRowNewCR = wsNew.Cells(Rows.Count, "E").End(xlUp).Row
            ' 在CR数据下方第3行添加DQM表头
            dqmHeaders = Array("ID", "名称", "状态", "备注") ' 替换为实际表头文本
            wsNew.Range("E" & lastRowNewCR + 3).Resize(1, UBound(dqmHeaders) + 1).Value = dqmHeaders
            
            ' 定义需要提取的DQM列（示例：iGrafxID在B列，提取B、C、E、F列）
            dqmTargetCols = Array("B", "C", "E", "F") ' 替换为实际需要提取的列名/列号
            lastRowDQM = wsDQM.Cells(Rows.Count, "B").End(xlUp).Row ' 假设iGrafxID在B列，替换为实际列
            
            ' 筛选匹配tabName的行
            For i = 2 To lastRowDQM
                If wsDQM.Cells(i, "B").Value = tabName Then ' 精确匹配，模糊匹配可改用InStr
                    ' 计算DQM数据填充起始行
                    Dim dqmStartRow As Long
                    dqmStartRow = lastRowNewCR + 5
                    ' 逐列赋值，只提取指定列数据
                    For j = 0 To UBound(dqmTargetCols)
                        wsNew.Cells(dqmStartRow, "E").Offset(0, j).Value = _
                            wsDQM.Cells(i, dqmTargetCols(j)).Value
                    Next j
                    dqmStartRow = dqmStartRow + 1
                End If
            Next i
        End If
    Next wsNew
    
    ' 释放对象
    Set wsNew = Nothing
    Set wsCR = Nothing
    Set wsDQM = Nothing
    Set wbTemplate = Nothing
    Set wbProcess = Nothing
    Set wbCR = Nothing
    Set wbDQM = Nothing
    
    MsgBox "数据填充完成！"
End Sub

关键要点说明 #

• InStr函数：用于判断CR表SORID列是否包含目标TabName，vbTextCompare参数实现忽略大小写匹配，如需精确匹配可直接用=判断。
• Range.Value赋值：直接将源区域的值传递给目标区域，避免复制粘贴的性能损耗和格式冲突。
• 动态行号定位：通过Cells(Rows.Count, 列).End(xlUp).Row获取各表最后数据行，保证填充位置准确。
• 指定列提取：通过数组定义DQM需要提取的列，循环赋值实现精准数据转移，避免冗余数据。

内容的提问来源于stack exchange，提问作者Shawn-rika