Excel VBA如何将DataEntry表数据匹配粘贴到对应工作表指定行

实现方案 #

核心逻辑为在目标工作表的B列精确匹配DataEntry表F2的日期值，定位到对应行后动态生成粘贴范围，替换原固定的C16:E16区域。

完整修改后代码 #

Sub CopyDieseltoSheets()
    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim nextRow As Integer, shCount As Integer, TabCount As Long
    Dim rng As Range, matchDate As Date, findRng As Range
    
    '初始化参数
    Set wsInput = ThisWorkbook.Sheets("DataEntry")
    matchDate = wsInput.Range("F2").Value '提前读取要匹配的日期，避免重复读取
    nextRow = 3
    shCount = 4
    TabCount = Sheets("COMPRESSOR AN01 - ROADSPAN").Index
    
    Do
        If ThisWorkbook.Sheets(shCount).Visible <> xlSheetHidden Then
            '读取待复制的源数据
            With wsInput
                Set rng = .Range(.Cells(nextRow, 2), .Cells(nextRow, 4))
                rng.Copy
            End With
            
            Set wsOutput = ThisWorkbook.Sheets(shCount)
            With wsOutput
                '在B列精确匹配日期
                Set findRng = .Columns("B:B").Find( _
                    What:=matchDate, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    MatchCase:=False _
                )
                
                '匹配到对应行则粘贴，未匹配则弹框提示
                If Not findRng Is Nothing Then
                    .Range("C" & findRng.Row & ":E" & findRng.Row).PasteSpecial _
                        xlPasteValues, _
                        Operation:=xlNone, _
                        SkipBlanks:=False, _
                        Transpose:=False
                Else
                    MsgBox "工作表【" & wsOutput.Name & "】未找到匹配日期：" & matchDate, vbExclamation
                End If
            End With
            
            '清空剪切板，避免残留提示
            Application.CutCopyMode = False
            nextRow = nextRow + 1
        End If
        
        shCount = shCount + 1
    Loop Until shCount = TabCount + 1
    
    Exit Sub
End Sub

关键优化说明 #

• 修复原代码中Cells未绑定工作表的隐患：原代码Cells(nextRow, 2)未加.前缀，会默认读取活动工作表的单元格，修改后绑定到wsInput避免运行异常
• 新增日期精确匹配逻辑：Find方法设置LookAt:=xlWhole实现精确匹配，避免部分字符匹配导致的定位错误
• 动态拼接粘贴范围：匹配到目标行号后，自动生成对应C-E列的粘贴范围，无需写死行号
• 新增容错处理：如果目标工作表未找到匹配日期，会弹出提示避免代码直接报错
• 增加剪切板清空逻辑，避免复制后残留的选中提示

内容的提问来源于stack exchange，提问作者VBA_Novice_123