复制和粘贴vba时脚本超出范围错误

您好，我需要帮助将不同工作表中的不同范围复制到新工作簿中，并根据原始文件中的列进行保存。我有两个工作表，sheet1和sheet2，每个工作表都有不同的数据范围，但它们都有一个列状态。我试图根据状态复制每个范围

我能够通过从sheet1复制和粘贴来创建新文件，当代码通过sheet2时，我有一个脚本超出范围的错误。第二个

窗口（sfilename1）出现错误。激活

Sub ExtractToNewWorkbook()
Dim ws1, ws2 As Worksheet
Dim wsOld, wsNew  As Workbook
Dim rData1, rData2  As Range
Dim rfl1, rfl2    As Range
Dim state1, state2  As String
Dim sfilename1 As String
Dim LR1, LR2 As Long

Set wsOld = Workbooks("reworkmonthly.xlsm")
Set ws1 = wsOld.Sheets("Sheet1")
Set ws2 = wsOld.Sheets("Sheet2")

LR1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
LR2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row

'Apply advance filter in your sheet
With ws1
Set rData1 = Range("A1", "E" & LR1)
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rfl1 In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state1 = rfl1.Text
Set wsNew = Workbooks.Add
sfilename1 = state1 & ".xlsx"

'Set the Location
ActiveWorkbook.SaveAs filepath & "\" & sfilename1
Application.DisplayAlerts = False
ws1.Activate
rData1.AutoFilter Field:=5, Criteria1:=state1
rData1.Copy
Windows(sfilename1).Activate
ActiveSheet.Paste
ActiveSheet.Columns("A:E").AutoFit
ActiveSheet.Name = "productinfo1"

With ActiveWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "productinfo2"
End With

ActiveWorkbook.Close SaveChanges:=True
Next rfl1

Application.DisplayAlerts = True
End With

ws1.Columns(Columns.Count).ClearContents
rData1.AutoFilter
With ws2
Set rData2 = Range("A1", "F" & LR2)
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rfl2 In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state2 = rfl2.Text
Set y = Workbooks.Open(File Path & sfilename1)
ws2.Activate
rData2.AutoFilter Field:=6, Criteria1:=state2
rData2.Copy
y.Worksheets("productinfo2").Activate
Worksheets("productinfo2").Paste
Worksheets("productinfo2").Columns("A:F").AutoFit
ActiveWorkbook.Close SaveChanges:=True
Next rfl2
End With

End Sub

我试过整理你的代码。让我知道进展如何。在哪里定义了
filepath

Sub ExtractToNewWorkbook()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim wsOld As Workbook, wsNew As Workbook, y As Workbook
Dim rData1 As Range, rData2 As Range
Dim rfl1 As Range, rfl2 As Range
Dim state1 As String, state2 As String
Dim sfilename1 As String
Dim LR1 As Long, LR2 As Long

Set wsOld = Workbooks("reworkmonthly.xlsm")
Set ws1 = wsOld.Sheets("Sheet1")
Set ws2 = wsOld.Sheets("Sheet2")

LR1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
LR2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row

With ws1
    Set rData1 = .Range("A1", "E" & LR1)
    .Columns(.Columns.Count).Clear
    .Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
    For Each rfl1 In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
        state1 = rfl1.Text
        Set wsNew = Workbooks.Add
        sfilename1 = state1 & ".xlsx"
        wsNew.SaveAs FilePath & "\" & sfilename1
        wsNew.Sheets(1).Name = "productinfo1"
        Application.DisplayAlerts = False
        rData1.AutoFilter Field:=5, Criteria1:=state1
        rData1.Copy wsNew.Sheets("productinfo1").Range("A1")
        wsNew.Sheets("productinfo1").Columns("A:E").AutoFit
        With wsNew
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "productinfo2"
        End With
        wsNew.Close SaveChanges:=True
    Next rfl1
    Application.DisplayAlerts = True
End With

ws1.Columns(Columns.Count).ClearContents
rData1.AutoFilter

With ws2
    Set rData2 = .Range("A1", "F" & LR2)
    .Columns(.Columns.Count).Clear
    .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
    For Each rfl2 In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
        state2 = rfl2.Text
        Set y = Workbooks.Open(FilePath & sfilename1)
        rData2.AutoFilter Field:=6, Criteria1:=state2
        rData2.Copy y.Worksheets("productinfo2").Range("A1")
        y.Worksheets("productinfo2").Columns("A:F").AutoFit
        y.Close SaveChanges:=True
    Next rfl2
End With

End Sub

您是否检查了
sfilename1
的值？大概这样的工作簿没有打开。顺便说一句，
Dim ws1，ws2 As Worksheet
相当于
Dim ws1 As variant，ws2 As Worksheet
-您需要同时指定两者。谢谢，关闭sfilename1后如何打开它？因为有一个变量取决于我的表1和表2。指定ws1和ws2是什么意思？我想我已经申报了。如果我拿出ws2，它就可以正常工作了。我只是不知道如何从sheet2复制和粘贴。因此我修改了代码，现在运行时没有错误，但代码不会将sheet2信息复制到新工作簿中。这是我的计算机桌面，因此我没有将其放在那里，但我可以轻松地将该部分添加到其中。谢谢，代码在您试图定义y的行中有一个运行时错误，它表示该文件不存在，即使它位于同一个文件夹中，这是奇怪的。当您将FilePath和sfilename1放在一起时，它显然不会生成有效的现有文件名。逐步检查代码以查看发生了什么。在第二个For循环中，您是否应该重新定义上一个块所继承的sfilename1？我的项目已更正，因为我应该拥有相同状态的sheet1和sheet2的相同记录。我尝试了你的代码，它现在通过它，但由于某种原因，不会复制某些州的sheet2数据。我现在只测试两个状态