Excel VBA宏输入日期查找对应列后复制指定行范围如何实现

我编写了一段Excel VBA宏，已实现功能为：在InputBox中输入日期后可查找匹配的日期列，现在需要在找到目标单元格后，复制该列下固定范围的行，相关代码如下：

Sub Makro10()
    Dim vDate As Date
    Dim wbMe As Workbook
    Dim data_wb As Workbook
    Dim ws As Worksheet
    Dim inputbx As String
    Dim DateIsValid As Boolean
    Dim file_name As Variant
    
    'Set workbook'
    Set wbMe = ActiveWorkbook
    wbMe.Sheets("input_forecast").Rows("1:1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "YYYY-MM-DD"
    
    Set wbMe = ThisWorkbook
    file_name = Application.GetOpenFilename(Title:="Choose a target Workbook")
    If file_name <> False Then
    
       'Set data file
       Set data_wb = Application.Workbooks.Open(file_name)
       
       'paste copy like value and change to date format'
       data_wb.Sheets("Final").Rows("1:1").Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        Selection.NumberFormat = "YYYY-MM-DD"
        'set our ws'
    
    ''' Put date input box  '''
        Do
            inputbx = InputBox("Date, FORMAT; 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 "Please enter a valid date.", vbExclamation
        Loop Until DateIsValid
    'COPY loop"
        Dim loc As Range, lc As Long
        With data_wb.Sheets("Final")
            Set loc = .Cells.Find(what:=Format(inputbx, "YYYY-MM-DD"))
            If Not loc Is Nothing Then
                lc = .Cells(loc.Row, Columns.Count).End(xlToLeft).Column
                .Range(.Cells(109, loc.Column), .Cells(123, lc)).Copy
            End If
        End With
    End If
End Sub

编辑补充：

你已经拿到了匹配日期的单元格对象loc，直接通过loc.Column获取目标列号，指定需要复制的起止行即可。原有代码里的lc变量是取当前行的最左列，和你需要的单目标列复制需求不符，直接删除即可。

核心修改点 #

1. 补全Find方法的全部匹配参数，避免继承Excel之前的手动查找配置导致匹配失效
2. 直接指定目标列的固定行范围，比如你要复制该列第109行到123行，直接写对应行号即可
3. 补充粘贴目标位置示例，你可以根据自己的需求修改粘贴地址

修改后完整代码 #

Sub Makro10()
    Dim vDate As Date
    Dim wbMe As Workbook
    Dim data_wb As Workbook
    Dim inputbx As String
    Dim DateIsValid As Boolean
    Dim file_name As Variant
    Dim loc As Range
    
    ' 处理当前工作簿表头格式
    Set wbMe = ThisWorkbook
    With wbMe.Sheets("input_forecast").Rows("1:1")
        .Value = .Value ' 替代复制粘贴值操作，执行效率更高
        .NumberFormat = "YYYY-MM-DD"
    End With
    
    ' 选择目标工作簿
    file_name = Application.GetOpenFilename(Title:="选择目标工作簿")
    If file_name = False Then Exit Sub
    
    ' 打开目标工作簿处理表头格式
    Set data_wb = Application.Workbooks.Open(file_name)
    With data_wb.Sheets("Final").Rows("1:1")
        .Value = .Value
        .NumberFormat = "YYYY-MM-DD"
    End With
    
    ' 日期输入校验
    Do
        inputbx = InputBox("请输入日期，格式：YYYY-MM-DD")
        If inputbx = vbNullString Then
            data_wb.Close SaveChanges:=False
            Exit Sub
        End If
        On Error Resume Next
        vDate = CDate(inputbx)
        On Error GoTo 0
        DateIsValid = IsDate(vDate)
        If Not DateIsValid Then MsgBox "请输入合法的日期格式", vbExclamation
    Loop Until DateIsValid
    
    ' 查找匹配日期列
    With data_wb.Sheets("Final")
        Set loc = .Rows(1).Find( _
            What:=vDate, _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            MatchCase:=False _
        )
        ' 找到后复制该列固定行范围，这里示例是复制109-123行，按需修改行号即可
        If Not loc Is Nothing Then
            ' 复制目标列固定行范围
            .Range(.Cells(109, loc.Column), .Cells(123, loc.Column)).Copy
            ' 示例：粘贴到当前工作簿input_forecast表的A109位置，按需修改粘贴目标
            wbMe.Sheets("input_forecast").Range("A109").PasteSpecial Paste:=xlPasteAll
            Application.CutCopyMode = False
            ' 可选操作：处理完关闭目标工作簿
            data_wb.Close SaveChanges:=False
            MsgBox "数据复制完成", vbInformation
        Else
            MsgBox "未找到匹配的日期", vbExclamation
            data_wb.Close SaveChanges:=False
        End If
    End With
End Sub

如果你的固定行范围不是109-123，直接修改对应行号数值即可。

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