VBA宏问题：跨工作簿复制粘贴单元格位置异常求助

原代码存在的问题 #

• 源文件路径错误：代码中"P: esource*"的 是无效转义字符，应改为"P:\resource*"；且直接用Workbooks.Open打开带通配符的文件会失败，需用Dir函数匹配目标文件。
• 未指定源工作表：Set RA = Range("H18:H100")未明确关联源工作簿的工作表，默认指向当前活动表，容易引发错误。
• 目标行定位逻辑错误：Range("X25").End(xlUp).Row + 1会从X25向上查找非空行，导致起始粘贴位置偏离X2；且未限定工作表，可能引用错误范围。
• 覆盖原有数据：删除X2:AI200后未正确定位到X列第一个空行（X2），导致后续粘贴位置混乱。

修正后的代码 #

Dim startRow As Long
Dim RA As Range
Dim checkcell As Range
Dim src As Workbook
Dim dest As Workbook
Dim wsDest As Worksheet
Dim srcWs As Worksheet
Dim targetRow As Long
Dim sourceFilePath As String

' 初始化目标工作簿和工作表
Set dest = ThisWorkbook
Set wsDest = dest.Sheets("Schichtplan")

' 清空目标区域（保留X1表头）
wsDest.Range("X2:AI200").ClearContents

' 匹配源文件路径（处理通配符）
sourceFilePath = Dir("P:\resource*.xlsx")
If sourceFilePath = "" Then
    MsgBox "未找到匹配的源文件！"
    Exit Sub
End If
Set src = Workbooks.Open("P:\" & sourceFilePath)

' 指定源工作表（根据实际情况修改工作表名称，比如"Sheet1"）
Set srcWs = src.Sheets("Sheet1")
Set RA = srcWs.Range("H18:H100")

' 初始化目标起始行
targetRow = 2

' 遍历查找加粗单元格并复制数据
For Each checkcell In RA
    If checkcell.Font.Bold = True Then
        ' 直接赋值替代复制粘贴，效率更高且避免剪贴板问题
        wsDest.Cells(targetRow, 24).Resize(1, 12).Value = checkcell.Offset(0, 7).Resize(1, 12).Value
        targetRow = targetRow + 1 ' 累加行号，避免覆盖
    End If
Next checkcell

' 关闭源工作簿（根据需求选择是否保存）
src.Close SaveChanges:=False
MsgBox "数据复制完成！"

关键修改说明 #

1. 路径处理：用Dir函数匹配带通配符的源文件，避免打开失败。
2. 明确工作表关联：所有Range对象都指定所属的工作簿和工作表，消除歧义。
3. 固定起始行+累加：从targetRow = 2开始，每复制一行就将行号+1，确保数据从X2开始依次向下粘贴，不会覆盖。
4. 替换复制粘贴：用直接赋值的方式传递数据，避免剪贴板依赖，提升宏的稳定性和效率。
5. 错误处理：增加源文件不存在的提示，避免宏无响应。

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