Loop creating new Workbooks, need to Save As and continue Loop

[kff082]

Hello,

My macro was built to loop through data of an original workbook and break out the data into individual workbooks based on the value of one field. The code works perfectly for creating the workbooks but I can not figure out how to get each workbook to save and continue on to the next. It seems to create/format the new workbook, names the workbook properly and then gets stuck without actually saving the workbook or moving on to the next new workbook. I have searched google for answers and I have failed. I would greatly appreciate any tips .

I have included my current code but because the macro is so large I have omitted the middle formatting section. Let me know if it would be more helpful to include this.

Sub Rep_Level_Bulk_Utilization()


Dim wsCurrent As Worksheet
Dim Bulksummarybymonth As Worksheet
Set Bulksummarybymonth = Worksheets("Bulk Summary Month View")
Dim wsNew As Workbook
Dim iLeft As Integer
Dim home As Range
Dim autoFilt As Range
Dim totalRow As Range
Dim focusArea As Range
Dim subTotaler As Range

' Turns off screen updating
Application.ScreenUpdating = False

Dim wb1 As Workbook
Set wb1 = ThisWorkbook

' Sorts worksheet by sold to AtoZ
Bulksummarybymonth.AutoFilter.Sort.SortFields. _
Clear
Bulksummarybymonth.AutoFilter.Sort.SortFields. _
Add Key:=Range("F18"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
With Bulksummarybymonth.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'This loop creates all the sheets
Set wsCurrent = wb1.Sheets("Bulk Summary Month View")

iLeft = Worksheets("Instructions").Range("G1").CurrentRegion.Rows.Count - 1

Do While iLeft > 0
Set wsNew = Workbooks.Add

With wb1.Sheets(2).Range("A18").CurrentRegion

.AutoFilter Field:=4, Criteria1:=wb1.Sheets("Instructions").Range("G1").Offset(iLeft).Value
.Copy Destination:=wsNew.Sheets(1).Range("A1")

' Takes cursor to the top
Set home = wsNew.Sheets(1).Range("A5")
Application.Goto home, Scroll = True
End With

'Saves document with proper name
Dim repNm As String
repNm = Range("D2").Value

Dim wsFun As WorksheetFunction: Set wsFun = Application.WorksheetFunction
Dim wt As Worksheet: Set wt = wb1.Sheets("Instructions")
Dim rngLoo As Range: Set rngLoo = ws.Range("G1:H10")
Dim cellNu As String
Dim currNam As String
Dim dt As String
Dim wbname As String

wbname = "Network\SWHQ2ADASD\WorkTeams\DomesticSales\Bulk Utilization\Bulk by Month - Rep Files\Rep Reporting - Bulk by Month - "
dt = Format(CStr(Now), "yymmdd")
cellNu = wsFun.VLookup(repNm, rngLook, 2, False)

ActiveWorkbook.SaveAs Filename:= _
wbname & cellNu & dt

iLeft = iLeft - 1
Loop