Excel VBA动态选择区域并跨工作簿复制粘贴的技术求助

我看了你的代码，发现几个关键问题会导致它没法正确完成任务：

• 依赖Select和Activate操作，这种方式不仅效率低，还容易因为窗口切换、工作表激活状态变化导致报错
• celltxt = ActiveSheet.Range("B1:B1000").Text只会返回B1单元格的文本，没法遍历整个B列去查找"CURRENT MONTH"
• 你硬编码了从B7开始取数据，但需求里说这个单元格位置是不固定的，所以这个逻辑完全不符合要求

下面是修正后的代码，解决了这些问题，同时更稳定高效：

Sub getCurrentMonth()
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim foundCell As Range
    Dim dataRange As Range
    
    ' 定义源工作簿和工作表（避免用Activate/Select）
    Set sourceWB = Workbooks("File1.xlsm")
    Set sourceWS = sourceWB.Sheets("Sheet1")
    
    ' 定义目标工作簿和工作表
    Set targetWB = Workbooks("Automation.xlsm")
    Set targetWS = targetWB.Sheets("Sheet1")
    
    ' 在B列查找包含"CURRENT MONTH"的单元格
    Set foundCell = sourceWS.Range("B:B").Find(What:="CURRENT MONTH", LookIn:=xlValues, LookAt:=xlPart)
    
    If Not foundCell Is Nothing Then
        ' 找到目标单元格后，确定要复制的区域：从下一行开始，到下一个空行的前一行
        ' 先获取数据区域的最后一行
        Dim lastDataRow As Long
        lastDataRow = sourceWS.Cells(foundCell.Row + 1, "B").End(xlDown).Row
        
        ' 处理边界情况：如果下一行就是空行，就不要复制（避免复制整列）
        If lastDataRow > foundCell.Row + 1 Then
            Set dataRange = sourceWS.Range(foundCell.Offset(1, 0), sourceWS.Cells(lastDataRow, "AD"))
            ' 复制到目标工作表的下一个空行
            dataRange.Copy
            targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Else
            MsgBox "找到""CURRENT MONTH""，但下方没有数据"
        End If
    Else
        MsgBox "未找到包含""CURRENT MONTH""的单元格"
    End If
    
    ' 清除剪贴板，避免弹窗提示
    Application.CutCopyMode = False
End Sub

关键改进点说明： #

• 避免Select/Activate：直接用对象变量引用工作簿和工作表，代码更稳定，不会因为窗口切换出问题
• 正确定位目标单元格：用Range.Find方法在整个B列查找"CURRENT MONTH"，不管它在哪个位置都能找到
• 安全处理数据区域：加入了边界判断，如果"CURRENT MONTH"下方没有数据，会给出提示，不会错误复制整列
• 高效粘贴：指定xlPasteValuesAndNumberFormats可以只粘贴值和格式，避免复制不必要的单元格属性，也可以根据需求改成xlPasteAll

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