跨工作薄，复制粘贴，报错,求解疑，谢谢。

weega

Sub 数据整理()
Dim ar As Variant
Dim br()

    Dim fname As String
    Dim fpath As String
    Dim maxLine As Integer
    Dim maxLineS As String
    Dim wb As Workbook
    Dim curSheet As String

ar = ActiveWorkbook.Worksheets(1).[a1].CurrentRegion
ReDim br(1 To UBound(ar) * 2 * UBound(ar, 2), 1 To 9)
ReDim brr(1 To UBound(ar) * 2 * UBound(ar, 2), 1 To 10)
For i = 1 To UBound(ar)
    For j = 3 To UBound(ar, 2) Step 6
        y = 2
        If Trim(ar(i, j)) <> "" Then
            n = n + 1
            br(n, 1) = ar(i, 1)    '循环整理影院名称

            br(n, 9) = ar(i, 2)    '循环整理日期



            br(n, 2) = ar(i, j)     '循环整理影片名称

            For s = j + 1 To j + 5 '循环整理影片的字段数据，5指5个字段
                y = y + 1
                br(n, y) = ar(i, s)
            Next s

        End If
    Next j
Next i
With Sheets("整理")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(br, 2)) = br
    Call Add
    .[a2].Resize(n, UBound(br, 2) + 1).Select
    Selection.Copy

   fpath = "E:\数据002\"
    fname = "数据追踪表 -0201.xlsx"
    curSheet = "输入表"
   
    '打开第二个工作薄，激活汇总表
    Set wb = Workbooks.Open(fpath + fname)
    wb.Worksheets(curSheet).Activate


    '找到最后一行
    maxLine = ActiveSheet.UsedRange.Rows.Count
    '选中最后一行下一行第一个表格
    Cells(maxLine + 1, 1).Select
    '粘贴


    ActiveSheet.Paste
    ActiveWorkbook.Save
    ActiveWorkbook.Close


End With




MsgBox "ok!"
End Sub

Sub Add()

Dim ar1 As Variant
ar1 = ThisWorkbook.Sheets("整理").[a1].CurrentRegion
For p = 2 To UBound(ar1)
    If Range("A" & p).Value <> "" Then
        Range("H" & p) = "=IFERROR(RC[-5]*RC[-3],0)"

        Range("J" & p) = "=VLOOKUP(RC[-9],R2C17:R25C18,2,0)"
    End If
Next p
End Sub

liulang0808

Dim br()
Dim brr()
增加一个看看吧，没有附件，不方便调测对比的