基于单元格值复制粘贴数据的Excel VBA实现问题求助

需求说明 #

根据冻结窗格中G1单元格的目标日期，复制A列中匹配该日期的A:Q行数据，粘贴到当前工作表的下一个空白行（例如G1输入2023/6/30时，复制A2:Q100中所有该日期的行，粘贴至A101开始的区域）。

原代码的问题 #

你提供的代码存在多处逻辑和语法错误：

• 变量d定义为Integer，却用来引用单元格地址字符串"G1"，类型不匹配
• For d = "G1" To "G1" 循环逻辑无效，无法实现遍历行的需求
• Cells("A2:A1750").Value 不能直接与单个单元格值做比较，需逐行检查A列单元格
• ActiveCell 未明确指向目标行，会导致复制错误的内容
• 粘贴位置使用Offset(1,1)会从B列开始粘贴，不符合从A列起始的需求

修正后的完整代码 #

Sub CopyMatchingDates()
    Dim targetDate As Date
    Dim lastRow As Long
    Dim i As Long
    Dim pasteRow As Long
    
    ' 获取G1中的目标日期
    targetDate = ThisWorkbook.ActiveSheet.Range("G1").Value
    
    ' 获取A列最后一行的行号（动态适配数据量）
    lastRow = ThisWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    ' 确定粘贴的起始行：当前数据区域的下一行
    pasteRow = lastRow + 1
    
    ' 遍历A2到最后一行的所有数据行
    For i = 2 To lastRow
        ' 检查当前行A列的日期是否匹配目标日期
        If ThisWorkbook.ActiveSheet.Range("A" & i).Value = targetDate Then
            ' 复制当前行的A到Q列数据
            ThisWorkbook.ActiveSheet.Range("A" & i & ":Q" & i).Copy
            ' 粘贴到目标行的A列起始位置
            ThisWorkbook.ActiveSheet.Range("A" & pasteRow).PasteSpecial xlPasteAll
            ' 更新粘贴行号，准备下一次粘贴
            pasteRow = pasteRow + 1
        End If
    Next i
    
    ' 清除剪贴板状态，避免Excel残留复制标记
    Application.CutCopyMode = False
End Sub

代码关键点说明 #

1. 动态获取行号：用lastRow自动获取A列最后一行，避免硬编码固定行号（如原代码的1750），适配数据量变化
2. 逐行匹配日期：遍历每一行的A列单元格，确保精准匹配目标日期
3. 精准复制粘贴范围：明确复制A:Q列，粘贴到下一个空白行的A列起始位置，符合需求
4. 清理剪贴板：执行Application.CutCopyMode = False，避免Excel保留复制状态影响后续操作

可选调整：粘贴到指定工作表 #

如果需要将数据粘贴到名为"2023"的工作表，可修改代码如下（仅调整涉及工作表的部分）：

Sub CopyMatchingDatesToSheet()
    Dim targetDate As Date
    Dim sourceLastRow As Long
    Dim i As Long
    Dim pasteRow As Long
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    
    ' 定义源工作表（数据所在表）和目标工作表（粘贴表）
    Set sourceSheet = ThisWorkbook.ActiveSheet
    Set targetSheet = ThisWorkbook.Sheets("2023")
    
    ' 获取G1中的目标日期
    targetDate = sourceSheet.Range("G1").Value
    
    ' 获取源表A列最后一行行号
    sourceLastRow = sourceSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    ' 获取目标表A列最后一行的下一行作为粘贴起始行
    pasteRow = targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    ' 遍历源表数据行
    For i = 2 To sourceLastRow
        If sourceSheet.Range("A" & i).Value = targetDate Then
            sourceSheet.Range("A" & i & ":Q" & i).Copy
            targetSheet.Range("A" & pasteRow).PasteSpecial xlPasteAll
            pasteRow = pasteRow + 1
        End If
    Next i
    
    Application.CutCopyMode = False
End Sub

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