Looping code not ending correctly

[cdb0ewm]

I have the following code that I use to create individual client files from one master spreadsheet. My problem is that it always creates and saves a blank file with only the 'rn' value in the file name. It seems that it is looping one extra time when the 'rng.value' list ends.

Any suggestions?

Sub MakeFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim criteriaRng As Range, usedRng As Range, rng As Range
Dim lh As String, ch As String, rh As String
Dim rn As String

rn = InputBox(Prompt:="Enter the date range")


Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("OUTPUT")
Set usedRng = ws.Range("A1:G" & ws.Range("A" & Rows.Count).End(xlUp).Row)

ws.Range("A1:A" & ws.Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("R1"), Unique:=True
Set criteriaRng = ws.Range("R2:R" & ws.Range("R" & Rows.Count).End(xlUp).Row)

With ThisWorkbook.Sheets("OUTPUT").PageSetup
lh = .LeftHeader
rh = .RightHeader
ch = .CenterHeader
End With

If ws.AutoFilterMode = False Then
ws.Range("A1").AutoFilter
End If

For Each rng In criteriaRng
usedRng.AutoFilter Field:=1, Criteria1:=rng.Value
Set wb = Workbooks.Add
usedRng.Copy

With wb.Sheets("Sheet1")
.Range("A1").PasteSpecial xlValues

.PageSetup.LeftMargin = Application.InchesToPoints(0.4)
.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
.PageSetup.RightMargin = Application.InchesToPoints(0.4)
.PageSetup.Zoom = False
.Range("B:G").VerticalAlignment = xlTop
.Range("B1:G1").HorizontalAlignment = xlCenter
.Range("B1:G1").VerticalAlignment = xlCenter
.Range("A:G").Font.Size = 10
.Range("A1:G1").Font.Size = 12
.Range("A:G").Font.Name = "Arial"
.Range("A1:G1").Font.Bold = True
.Range("F:F").Font.Size = 12
.SaveAs ThisWorkbook.Path & "\" & rng.Value & " " & rn & ".xls"
End With
wb.Close
Next rng

ws.Columns("R:R").Delete
ws.Range("A1").AutoFilter
End Sub

 

[jsotola]

here is your code with debug code added

singlestep through your code
(click anywhere in code and start pressing F8)

i think that you will find that a blank row is being processed

you can set breakpoints by clicking in the gray vertical bar just on left edge of the code window
(you should see a red dot and command line should be highlighted red)

press F5 to run code, it will stop at breakpoints

just singlestep through code (F8) first few loops until you figure out where you want to put breakpoints

then just use F5 to get to the breakpoint, and use F8 to singlestep after breakpoint
(press F5 at any time to resume run)

Sub MakeFiles()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim criteriaRng As Range, usedRng As Range, rng As Range
    Dim lh As String, ch As String, rh As String
    Dim rn As String
    
    rn = InputBox(Prompt:="Enter the date range")
    
[COLOR=#ff0000]    ' commented out for debugging[/COLOR]
[COLOR=#ff0000][SIZE=4]'[/SIZE][/COLOR]    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("OUTPUT")
    
    Set usedRng = ws.Range("A1:G" & ws.Range("A" & Rows.Count).End(xlUp).Row)


[COLOR=#ff0000]usedRng.Select ' debug[/COLOR]
    
    ws.Range("A1:A" & ws.Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("R1"), Unique:=True
    
    Set criteriaRng = ws.Range("R2:R" & ws.Range("R" & Rows.Count).End(xlUp).Row)


[COLOR=#ff0000]criteriaRng.Select ' debug  (there is probably a blank row in this range)[/COLOR]
    
    With ThisWorkbook.Sheets("OUTPUT").PageSetup
        lh = .LeftHeader
        rh = .RightHeader
        ch = .CenterHeader
    End With
    
    If Not ws.AutoFilterMode Then ws.Range("A1").AutoFilter    ' simple if commands can be on one line
    
    For Each rng In criteriaRng
        usedRng.AutoFilter Field:=1, Criteria1:=rng.Value
        Set wb = Workbooks.Add
        usedRng.Copy
        
        With wb.Sheets("Sheet1")
            .Range("A1").PasteSpecial xlValues
            
            .PageSetup.LeftMargin = Application.InchesToPoints(0.4)
            .PageSetup.BottomMargin = Application.InchesToPoints(0.5)
            .PageSetup.RightMargin = Application.InchesToPoints(0.4)
            .PageSetup.Zoom = False
            .Range("B:G").VerticalAlignment = xlTop
            .Range("B1:G1").HorizontalAlignment = xlCenter
            .Range("B1:G1").VerticalAlignment = xlCenter
            .Range("A:G").Font.Size = 10
            .Range("A1:G1").Font.Size = 12
            .Range("A:G").Font.Name = "Arial"
            .Range("A1:G1").Font.Bold = True
            .Range("F:F").Font.Size = 12
            .SaveAs ThisWorkbook.Path & "\" & rng.Value & " " & rn & ".xls"
        End With
        wb.Close
    Next rng
    
    ws.Columns("R:R").Delete
    ws.Range("A1").AutoFilter
End Sub