循环复制后出现问题

fhv123

将文件放到  D:\date
代码功能说明：将统计表的3至6列分别复制到模板的第3列，按名称保存好
代码的问题：生成后的工作薄第3列复制的都是统计表的最后一列，不是对应该的3-6列
Sub ss()
Excel.Application.ScreenUpdating = False
Excel.Application.CutCopyMode = False
Excel.Application.DisplayAlerts = False
Dim wb1, wb2 As Workbook
Dim i As Integer
Dim nrow%
Dim arr1()

    nrow = Sheet1.Range("l65536").End(xlUp).Row
    Set wb1 = ActiveWorkbook
    ReDim arr1(3 To nrow)

    Workbooks.Open Filename:=Range("p1") & "\" & Range("q1") '打开d:\date\模板
    Set wb2 = ActiveWorkbook
        For i = 3 To nrow
            wb1.Sheets("资料").Activate
            arr1(i) = Range("p1") & "\" & i - 2 & "-" & Range("l" & i) & ".xlsx" '定义个数组，存放文件夹保存的位置
            Range("A" & i).EntireRow.Copy wb2.Sheets("资料").Range("a3") '统计表的第3-7列复制到模板的第3列
            wb2.Sheets("资料").Activate
            Range("a1").Select
            wb2.SaveCopyAs Filename:=arr1
        Next
        wb2.Save
        wb2.Close
Excel.Application.DisplayAlerts = True
Excel.Application.CutCopyMode = True
Excel.Application.ScreenUpdating = True
End Sub

fhv123

哪位大神帮忙审审代码

fhv123

我找到问题所在了，是数组出现了问题，留给后来者做个参考吧
Sub ss()
Excel.Application.ScreenUpdating = False
Excel.Application.CutCopyMode = False
Excel.Application.DisplayAlerts = False
Dim wb1, wb2 As Workbook
Dim i As Integer
Dim nrow%
Dim arr1()

    nrow = Sheet1.Range("l65536").End(xlUp).Row
    Set wb1 = ActiveWorkbook
    ReDim arr1(3 To nrow)

    Workbooks.Open Filename:=Range("p1") & "\" & Range("q1") '打开d:\date\模板
    Set wb2 = ActiveWorkbook
        For i = 3 To nrow
            wb1.Sheets("资料").Activate
            arr1(i) = Range("p1") & "\" & i - 2 & "-" & Range("l" & i) & ".xlsx" '定义个数组，存放文件夹保存的位置
            Range("A" & i).EntireRow.Copy wb2.Sheets("资料").Range("a3") '统计表的第3-7列复制到模板的第3列
            wb2.Sheets("资料").Activate
            Range("a1").Select
            wb2.SaveCopyAs Filename:=arr1(i)
        Next
        wb2.Save
        wb2.Close
Excel.Application.DisplayAlerts = True
Excel.Application.CutCopyMode = True
Excel.Application.ScreenUpdating = True
End Sub