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

Question

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

我能够通过从 sheet1 复制和粘贴来创建新文件，但当代码通过 sheet2 时，脚本超出范围时出现错误。错误在第二个Windows(sfilename1).Activate

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

Answer 1

我已经开始整理您的代码了。让我知道事情的后续。 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