VBA复制单元格区域至最后空行的排版与报错问题求助

一、先搞定“后续区域挤同一行”的排版问题 #

要解决这个问题，核心是精准定位目标列的最后非空行，别用整行的End(xlUp)判断，不然很容易踩坑。给你个靠谱的写法：

Dim wsDest As Worksheet
Set wsDest = ThisWorkbook.Worksheets("目标表") '替换成你的目标工作表名

'比如要粘贴到A列开头，先找A列最后有内容的行
Dim lastRow As Long
lastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row

'下一个空行就是lastRow + 1，直接粘贴
wsDest.Cells(lastRow + 1, "A").PasteSpecial xlPasteAll '按需改粘贴类型，比如xlPasteValues

如果是按列循环粘贴（比如你用j做列索引），得给每列单独计算最后非空行，不能共用一个行号：

For j = 1 To 5 '假设循环1到5列
    lastRow = wsDest.Cells(wsDest.Rows.Count, j).End(xlUp).Row
    '把复制的区域粘贴到当前列的下一行
    sourceRange.Copy wsDest.Cells(lastRow + 1, j)
Next j

二、Offset(1,j)触发1004错误的排查方向 #

这个错误常见原因就几个，挨个排查：

• j的值超出工作表最大列数：Excel 2007及以后版本最多支持16384列，要是你的j循环到比16384大的数，直接触发错误。先检查j的取值范围，确保j <= 16384。
• 未指定具体工作表对象：要是你写Cells(lastRow,1).Offset(1,j)，默认会用当前激活的工作表，若激活的不是目标表，必然出错。必须明确指定工作表：

  '错误写法：未指定工作表
  'Cells(lastRow,1).Offset(1,j).PasteSpecial...
  '正确写法：指定目标工作表
  wsDest.Cells(lastRow,1).Offset(1,j).PasteSpecial xlPasteAll
  

• 目标工作表被保护：要是目标工作表开启了保护，且未允许编辑单元格，操作会被权限拦截。可以先取消保护，完成操作后再恢复：

  wsDest.Unprotect Password:="你的密码" '无密码则去掉Password参数
  '执行粘贴操作
  wsDest.Protect Password:="你的密码" '恢复保护
  

• 复制与粘贴区域不匹配：Offset后的单元格范围和复制的区域大小不一致，也会报错。不如直接用Copy方法指定起始单元格，自动匹配区域大小：

  sourceRange.Copy wsDest.Cells(lastRow + 1, j) '无需PasteSpecial也能正常复制
  

三、完整示例代码 #

把上面的逻辑整合起来，适配你的需求——当某区域值为1时，从另一个工作簿复制区域到目标表对应位置：

Sub CopyOnValue1()
    Dim wsCheck As Worksheet
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim checkRng As Range
    Dim cell As Range
    Dim lastRow As Long
    Dim j As Integer
    
    '替换成你的实际工作表/文件路径
    Set wsCheck = ThisWorkbook.Worksheets("检查用表")
    Set wbSource = Workbooks.Open("C:\你的数据源文件.xlsx")
    Set wsSource = wbSource.Worksheets("数据源表")
    Set wsDest = ThisWorkbook.Worksheets("目标表")
    Set checkRng = wsCheck.Range("A1:A10") '你要检查值为1的区域
    
    For Each cell In checkRng
        If cell.Value = 1 Then
            '假设复制数据源的B2:D2区域，按需修改
            Dim copyRng As Range
            Set copyRng = wsSource.Range("B2:D2")
            
            '按列循环粘贴到目标表对应列
            For j = 1 To copyRng.Columns.Count
                lastRow = wsDest.Cells(wsDest.Rows.Count, j).End(xlUp).Row
                copyRng.Columns(j).Copy wsDest.Cells(lastRow + 1, j)
            Next j
        End If
    Next cell
    
    '关闭数据源文件，不保存（要保存就改成True）
    wbSource.Close SaveChanges:=False
End Sub

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