VBA实现按输入日期匹配同名列跨文件粘贴选定区域数据

修正后完整实现代码 #

你需要先在目标工作表input_4的首行查找和输入日期匹配的列，找到对应列后再执行数值粘贴操作，完整修改后的代码如下：

''' 日期输入校验模块 '''
Do
    inputbx = InputBox("请输入日期，格式要求：YYYY-MM-DD")
    If inputbx = vbNullString Then Exit Sub
    On Error Resume Next
    vDate = CDate(inputbx)
    On Error GoTo 0
    DateIsValid = IsDate(vDate)
    If Not DateIsValid Then MsgBox "请输入合法的日期格式", vbExclamation
Loop Until DateIsValid

' 数据复制粘贴模块
Dim loc As Range, lc As Long, targetLoc As Range
Dim targetDateStr As String
' 统一转换为字符串匹配格式，避免日期存储格式差异导致匹配失败
targetDateStr = Format(vDate, "YYYY-MM-DD")

With data_wb.Sheets("Final")
    Set loc = .Cells.Find(what:=targetDateStr, LookIn:=xlValues, LookAt:=xlWhole)
    If Not loc Is Nothing Then
        ' 复制目标日期列的109-123行区域
        .Range(.Cells(109, loc.Column), .Cells(123, loc.Column)).Copy
        ' 查找目标表匹配的日期列
        With wbMe.Sheets("input_4")
            Set targetLoc = .Rows(1).Find(what:=targetDateStr, LookIn:=xlValues, LookAt:=xlWhole)
            If Not targetLoc Is Nothing Then
                ' 找到对应列后仅粘贴数值
                .Cells(1, targetLoc.Column).PasteSpecial Paste:=xlPasteValues
                ' 清空剪贴板
                Application.CutCopyMode = False
            Else
                MsgBox "目标工作表中未找到日期为【" & targetDateStr & "】的对应列", vbExclamation
            End If
        End With
    Else
        MsgBox "数据源工作表中未找到日期为【" & targetDateStr & "】的对应列", vbExclamation
    End If
End With

关键调整说明 #

• 新增targetLoc变量专门匹配目标表首行的日期列，匹配时指定LookAt:=xlWhole参数避免部分匹配的错误
• 统一用格式化后的日期字符串targetDateStr作为两个工作表的匹配依据，避免日期存储格式差异导致匹配失败
• 新增双端匹配失败的提示逻辑，方便快速排查问题
• 如果你的需求是复制日期列开始到行末的所有列，只需把复制区域改回原代码的.Range(.Cells(109, loc.Column), .Cells(123, lc))即可，粘贴逻辑无需调整

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