script out of range error when copying and pasting vba

Question

Hi I need help with copying different ranges from different worksheets into a new workbook & saving based on column in my original file. I have 2 worksheets, sheet1 & sheet2 each with different range of data but they all have a column State. I am trying to copy each range based on state.

I was able to create the new file with copying & pasting from sheet1 and I have an error on script out of range when codes pass through sheet2. Error is on the second 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

And have you checked the value of sfilename1? Presumably such a workbook is not open. — SJR
As an aside, Dim ws1, ws2 As Worksheet is equivalent to Dim ws1 as variant, ws2 As Worksheet - you need to specify both. — SJR
Thanks, how can I open sfilename1 after I close it? Since there will be a variable depending on my sheet1 & sheet2. What did you mean by specifying ws1 & ws2 ? I thought I have declared it already. If I take out ws2 it works just fine. I just don't know how to incorporate with copying & pasting from sheet2. — sc1324
So I modified my codes and now it has no error when running but the codes don't copy sheet2 info into the new workbook. — sc1324

SJR SJR · Accepted Answer · 2018-04-27T20:00:38

I've had a go at tidying up your code. Let me know how it goes. Where is filepath defined?

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

script out of range error when copying and pasting vba

1 Answers