跨工作簿按标题复制粘贴VBA报错1004及11位数字格式设置求助

一、错误1004的原因与修复 #

错误出现在lastCol = sh1.Cells(1, Columns.Count).End(xlToLeft).Column，核心原因是未指定Columns.Count的父对象——Columns.Count默认指向当前活动工作表，而非目标源表sh1，导致对象引用混淆触发错误。此外，若源表第一行全为空，也会触发该错误，需添加空值判断。

修复后的该行代码需明确指定父对象：

lastCol = sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column

同时建议增加表头空值判断，避免无数据时崩溃：

If sh1.Cells(1, 1).Value = "" And sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column = 1 Then
    MsgBox "源工作表第一行无表头数据"
    Exit Sub
End If

二、设置11位数字显示格式 #

要让粘贴后的数字显示为100xxxxxxxx格式，通过设置单元格自定义格式即可实现。在匹配到目标列后，添加格式设置代码：

sh2.Cells(lr2, f.Column).Resize(lr1 - 1).NumberFormat = """100""########"

该格式强制显示前缀100，后续跟随8位数字（不足8位自动补0，超过8位按实际数值显示），最终呈现11位的100xxxxxxxx样式。

三、完整修正代码 #

Sub Rectangle1_Click()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim wb1 As Workbook, wb2 As Workbook
    Dim j As Long, lr1 As Long, lr2 As Long, lastCol As Long
    Dim f As Range
    Application.ScreenUpdating = False

    ' 捕获工作簿未打开的错误
    On Error Resume Next
    Set wb1 = Workbooks("S.xls")
    Set wb2 = Workbooks("PD.xlsm")
    On Error GoTo 0
    
    If wb1 Is Nothing Or wb2 Is Nothing Then
        MsgBox "请确保S.xls和PD.xlsm均已打开"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    Set sh1 = wb1.Sheets(1) ' 源工作表
    Set sh2 = wb2.Sheets("PD") ' 目标工作表

    ' 获取源表最后一行（兼容空表）
    lr1 = 1
    On Error Resume Next
    lr1 = sh1.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
    On Error GoTo 0
    
    ' 获取目标表起始行（兼容空表）
    lr2 = 2
    On Error Resume Next
    lr2 = sh2.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
    On Error GoTo 0

    ' 获取源表表头最后一列（修复对象引用问题）
    lastCol = 1
    On Error Resume Next
    lastCol = sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column
    On Error GoTo 0
    
    ' 判断源表表头是否为空
    If sh1.Cells(1, 1).Value = "" And lastCol = 1 Then
        MsgBox "源工作表第一行无表头数据"
        wb1.Close False
        Application.ScreenUpdating = True
        Exit Sub
    End If

    ' 按表头匹配复制数据并设置格式
    For j = 1 To lastCol
        Set f = sh2.Rows(1).Find(sh1.Cells(1, j), , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then
            ' 复制数据：排除表头行，复制实际数据行
            sh2.Cells(lr2, f.Column).Resize(lr1 - 1).Value = sh1.Cells(2, j).Resize(lr1 - 1).Value
            ' 设置11位显示格式
            sh2.Cells(lr2, f.Column).Resize(lr1 - 1).NumberFormat = """100""########"
        End If
    Next j

    wb1.Close False
    Application.ScreenUpdating = True
    MsgBox "处理完成"
End Sub

额外优化说明 #

• 新增工作簿存在性检查，避免因目标文件未打开导致的崩溃
• 修复了Resize(lr1)的逻辑错误：原代码会复制包含表头的lr1行，实际应从第2行开始复制lr1-1行数据
• 对行列数获取、Find方法添加了错误捕获，提升代码稳定性

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