Not able to get out of loop - its loop within a loop

ndbhatt · Nov 22, 2005

I am trying to ddo the following:

Main Workbook has following dataheaders
LoanID SM Region data2

1. First I am get the unique values of each region

2. Then apply auto filter to get only rows for first unique region

3. Create a new workbook

4. Paste the rows from step 2

5. Get the unique values for each SM (now its only within that region)

6. Create worksheets within that workbook by SM

7. Once all the SM's are done save that workbook with Region name.

8. Start with workbook for the next region as in step 1

Continue this till workbooks for all region are created and saved.

I am getting error in the outermost loop.

Please find the code as follows:

=====

Sub CreateRegion()

Dim i As Integer
Dim j As Integer
Dim ThisSheet As Worksheet
Dim InnerSheet As Worksheet
Dim Wk As Workbook
Dim Region As String
Dim SM As String
Application.ScreenUpdating = False
Set ThisSheet = ActiveSheet

With ThisSheet
'Turn off AutoFilters
.AutoFilterMode = False
'Filter out all unique Region _
and put them in Column E
.Columns(3).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("E1"), Unique:=True

'Loop through and filter by all unique Regions _
then create a worbbook named after each Region.
'Then copy the data for that Region to it's sheet
For i = 2 To WorksheetFunction.CountA(.Columns("E:E"))
Region = .Cells(i, 5)

'Turn on Autofilter if needed
If .AutoFilterMode = False Then .Rows(1).AutoFilter

'Filter down by Region and copy visible cells _
of columns A:D
.Rows(1).AutoFilter Field:=3, Criteria1:=Region
.Columns("A:D").SpecialCells(xlVisible).Copy

'Adding new workbook for each region

Set Wk = Workbooks.Add
Application.DisplayAlerts = False

'Paste new region level data dump on sheet
ActiveSheet.Paste

'New Region level data manipulation starts in workbook

With ThisWorkbook.ActiveSheet
'Turn off AutoFilters
.AutoFilterMode = False
'Filter out all unique Sales Managers _
and put them in Column E
.Columns(2).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("F1"), Unique:=True

'Loop through and filter by all unique Sales Manager _
then create a worksheet named after each Sales Manager.
'Then copy the data for that Sales Manager to it's sheet
 For j = 2 To WorksheetFunction.CountA(.Columns("E:E"))
 SM = .Cells(i, 5)

 'Turn on Autofilter if needed
 If .AutoFilterMode = False Then .Rows(1).AutoFilter

 'Filter down by Sales Manager and copy visible cells _
 of columns A:D
 .Rows(1).AutoFilter Field:=2, Criteria1:=SM
 .Columns("A:D").SpecialCells(xlVisible).Copy


 'Add a sheet named after SM
 Sheets.Add().Name = SM

 'Paste new data on sheet
 ActiveSheet.Paste

 Next j

 Wk.SaveAs Filename:="C:/" & Region
 ActiveWorkbook.Close True
 'Here is here I get error (at Next i) - Compile Error: Next without for
Next i

.AutoFilterMode = False
End With

Set ThisSheet = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub=====

I hope someone can get this working.

Thanks in advance.

- Nick

Tazguy37 · Nov 22, 2005

You're missing an "End With" in there somewhere. You've got two "With"'s and only one "End With".

ndbhatt · Nov 23, 2005

Done with missing "End With" but newer problem cro

First of all thanks to Tazguy for picking up missing code. I have fixed it but now it seems that still there is some problem. I have commented in the inner loop about the problem.

====

Sub CreateRegion()

Dim i As Integer
Dim j As Integer
Dim ThisSheet As Worksheet
Dim InnerSheet As Worksheet
Dim Wk As Workbook
Dim Region As String
Dim SM As String
Application.ScreenUpdating = False
Set ThisSheet = ActiveSheet

With ThisSheet
'Turn off AutoFilters
.AutoFilterMode = False
'Filter out all unique Region _
and put them in Column E
.Columns(3).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("E1"), Unique:=True

'Loop through and filter by all unique Regions _
then create a worbbook named after each Region.
'Then copy the data for that Region to it's sheet
For i = 2 To WorksheetFunction.CountA(.Columns("E:E"))
Region = .Cells(i, 5)

'Turn on Autofilter if needed
If .AutoFilterMode = False Then .Rows(1).AutoFilter

'Filter down by Region and copy visible cells _
of columns A:D
.Rows(1).AutoFilter Field:=3, Criteria1:=Region
.Columns("A:D").SpecialCells(xlVisible).Copy

'Adding new workbook for each region

Set Wk = Workbooks.Add
Application.DisplayAlerts = False

'Paste new region level data dump on sheet
ActiveSheet.Paste

'New Region level data manipulation starts in workbook
Set InnerSheet = ActiveSheet
' The value of InnerSheet read 'Nothing' Is this a problem
With InnerSheet
'Turn off AutoFilters
.AutoFilterMode = False
'Filter out all unique Sales Managers _
and put them in Column E
.Columns(2).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("E1"), Unique:=True

'Loop through and filter by all unique Sales Manager _
then create a worksheet named after each Sales Manager.
'Then copy the data for that Sales Manager to it's sheet
 For j = 2 To WorksheetFunction.CountA(.Columns("E:E"))
 SM = .Cells(i, 5)

 'Turn on Autofilter if needed
 If .AutoFilterMode = False Then .Rows(1).AutoFilter

 'Filter down by Sales Manager and copy visible cells _
 of columns A:D
 .Rows(1).AutoFilter Field:=2, Criteria1:=SM
 .Columns("A:D").SpecialCells(xlVisible).Copy

 '=====Error Message in Here
 'Add a sheet named after SM
 ' for the value of j=2 it adds a sheet but for next j value it still reads j=2 with error " Cannot rename the sheet
 Sheets.Add().Name = SM
 '=====Error Message in Here

 'Paste new data on sheet
 ActiveSheet.Paste

 Next j

 Wk.SaveAs Filename:="C:/" & Region
 ActiveWorkbook.Close True
 'Here is where I was getting error (at Next i) - Compile Error: Next without for
 End With 'This piece of code was missing
Next i

.AutoFilterMode = False
End With

Set ThisSheet = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


====

Tazguy37 · Nov 23, 2005

Got some small sample worksheet data to post too? It helps (me at least) if I can copy your data to a worksheet and "play computer," as it were. Thanks!

ndbhatt · Nov 28, 2005

stupid of me

I am looking for an option to attach the sample file. Really can't figure this one out. there are A-W columns.

Tazguy37 · Nov 28, 2005

Download Colo's HTML Maker utility for displaying your Excel Worksheet on the board.

Also read the HTML Maker FAQ.

ndbhatt · Nov 30, 2005

here you go..

Book2

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

1

Subtotal-loanamt???

2

loan_number

application_date

Acct_Exec

Sales_Mgr

region_nm

division_nm

loan_amount

branch_name

borrower_name

broker

data1

data2

data3

data4

data5

data6

data7

data8

data9

data10

data11

data12

3

123

8/23/0412:00AM

abc

rewind

dummy1

EastDivision

$53,040

north

kacson

abc,inc

7.95

9.1

1.25

0

4

456

9/8/0412:00AM

xyz

forward

dumm2

EastDivision

$121,550

south

mike

xyz,inc

8.15

8.4

0.25

0

Sheet2

I was wondernig if i can have a header on the top with subtotal for that column. Caveat! This will require all my autofilters to be added to second row and also this is pasted dynamically and the code is as follows:PublicFunction IsWsBlank(wsNameAsString,Optional wbNameAsString)AsBoolean
 Dim cntAsLong
 If ActiveWorkbookIsNothingThenExitFunction
 If wbName = ""Then wbName = ActiveWorkbook.Name
 cnt = Application.CountA(Workbooks(wbName).Sheets(wsName).Cells)
 If cnt = 0Then IsWsBlank =TrueEndFunctionSub CreateRegion()Dim iAsIntegerDim jAsIntegerDim SheetCountAsIntegerDim aAsIntegerDim bAsIntegerDim strStampAsStringDim MstrAsStringDim ThisSheetAs WorksheetDim InnerSheetAs WorksheetDim wsAs WorksheetDim wisAs WorksheetDim wssAs WorksheetDim WkAs WorkbookDim region_nmAsStringDim Sales_MgrAsStringDim StartAs WorksheetDim LastRowAsLong, LastColAsLong
Application.ScreenUpdating =FalseSet ThisSheet = ActiveSheet'Code to Create "excel_rpts" folder under C drive to store all reports start here

 Const myPath = "C:\excel_rpts\"

 Dim FileNameAsString, FolderNameAsString
 Dim fsAsObject, chkAsBoolean

 FolderName = myPath

 'checks if folder exists
 Set fs = CreateObject("Scripting.FileSystemObject")
 chk = fs.folderexists(FolderName)

 If chk =TrueThen
 MsgBox ("Folder excel_rpts already exists under C drive")

 Else
 'if folder does not exist, create folder
 If chk =FalseThen fs.createfolder (FolderName)
 MsgBox ("Folder excel_rpts created under C drive")
 EndIf'Code to Create "excel_rpts" folder under C drive to store all reports ends hereWith ThisSheet'Turn off AutoFilters
.AutoFilterMode =False'Filter out all unique region_nm _
and put them in Column X
.Columns(5).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("X1"), Unique:=True'Loop through and filter by all unique region_nm _
then create a workbook named after each Region.'Then copy the data for that Region to it's sheetFor i = 2To WorksheetFunction.CountA(.Columns("X:X"))
region_nm = .Cells(i, 24)'Turn on Autofilter if neededIf .AutoFilterMode =FalseThen .Rows(1).AutoFilter'Filter down by Region and copy visible cells _
of columns A:W
.Rows(1).AutoFilter Field:=5, Criteria1:=region_nm
.Columns("A:W").SpecialCells(xlVisible).Copy'Adding new workbook for each regionSet Wk = Workbooks.Add
Application.DisplayAlerts =False'Paste new region level data dump on sheet
ActiveSheet.Paste'New Region level data manipulation starts in workbookSet InnerSheet = ActiveSheet' The value of InnerSheet read 'Nothing' Is this a problemWith InnerSheet'Turn off AutoFilters
.AutoFilterMode =False'Filter out all unique Sales Managers _
and put them in Column X
.Columns(4).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("X1"), Unique:=True'Loop through and filter by all unique Sales Manager _
then create a worksheet named after each Sales Manager.'Then copy the data for that Sales Manager to it's sheet
 For j = 2To WorksheetFunction.CountA(.Columns("X:X"))
 Sales_Mgr = .Cells(j, 24)

 'Turn on Autofilter if needed
 If .AutoFilterMode =FalseThen .Rows(1).AutoFilter

 'Filter down by Sales Manager and copy visible cells _
 of columns A:W
 .Rows(1).AutoFilter Field:=4, Criteria1:=Sales_Mgr
 .Columns("A:W").SpecialCells(xlVisible).Copy

 'Add a sheet named after Sales_Mgr

 'Restrict the length of Sales_Mgr name to 31 chars
 If Len(Sales_Mgr) > 31Then Sales_Mgr = Left(Sales_Mgr, 31)
 If Sales_Mgr = "N/A N/A"Then Sales_Mgr = "N-A - N-A"

 Sheets.Add().Name = Sales_Mgr


 'Paste new data on sheet
 ActiveSheet.Paste

 Next j

 'Code for Deleting Blank worksheets starts here

 With Application
 ' Suppress Messages
 .DisplayAlerts =False
 ' Stop Screen "Flashing"
 .ScreenUpdating =False

 ' Delete Unused Worksheets
 ForEach wsIn Worksheets
 If WorksheetFunction.CountA(ws.Cells) = 0Then
 ws.Delete
 EndIf
 Next ws

 .DisplayAlerts =True
 .ScreenUpdating =True
 EndWith



 'Code for Deleting Blank worksheets ends here

 'Sorting of the worksheet starts from here


 SheetCount = Worksheets.Count

 If SheetCount< 2Then
 ExitSub
 Else
 For c = 1To SheetCount
 For a = 1To SheetCount - 1
 For b = a + 1To SheetCount

 If Worksheets(b).Name< Worksheets(a).NameThen
 Worksheets(b).Move Before:=Worksheets(a)
 EndIf

 Next b

 Next a

 If Worksheets(c).Name = "Sheet1"Then
 Worksheets(c).Move After:=Worksheets(SheetCount)
 If region_nm = "N/A"Then region_nm = "N-A"
 Mstr = "Master Data - " & region_nm
 If Len(Mstr) > 31Then Mstr = Left(Mstr, 31)

 Worksheets(SheetCount).Name = Mstr
 Selection.AutoFilter
 GoTo fmt:
 EndIf
 Next c

 EndIf

 'Sorting of the worksheet ends from here




 'Formatting of the report starts here

fmt:
 Application.ScreenUpdating =False
 ForEach wsIn ActiveWorkbook.Worksheets
 ws.Activate

 With ActiveSheet

 '===

 If ActiveWorkbookIsNothingThenExitSub
 Set Start = ActiveSheet
 ForEach wisIn ActiveWorkbook.Worksheets
 IfNot IsWsBlank(wis.Name, wis.Parent.Name)Then
 LastRow = wis.Cells.Find("*", After:=wis.Cells(1, 1), _
 searchorder:=xlByRows, _
 searchdirection:=xlPrevious).Row
 LastCol = wis.Cells.Find("*", After:=wis.Cells(1, 1), _
 searchorder:=xlByColumns, _
 searchdirection:=xlPrevious).Column
 With wis.Range("A1", wis.Cells(LastRow, LastCol))
 .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
 .Borders(xlInsideVertical).Weight = xlThin
 .Borders(xlInsideHorizontal).Weight = xlThin
 wis.Activate
 ActiveWindow.DisplayGridlines =False
 EndWith
 EndIf
 Next wis
 Start.Select
 '===
 .Range("A1:W1").Select
 Selection.AutoFilter
 'ActiveSheet.UsedRange.Select
 Selection.AutoFormat Format:=xlRangeAutoFormatList1, Number:=True, Font:= _
 True, Alignment:=True, Border:=True, Pattern:=True, Width:= _
 True

 .Cells.Select
 .Cells.EntireColumn.AutoFit

 'small code to take care of print preview and Orientation
 With Sheets(ws.Name).PageSetup
 .PrintTitleRows = "$1:$23"
 .Orientation = xlLandscape
 .FitToPagesTall =False
 .FitToPagesWide = 1
 .Zoom =False



 EndWith
 EndWith
 Next ws

 'Formatting of the report ends here

 'Append timestamp to files created
 strStamp = Format(Now, "dd-mmmm-yy hhmm")
 ChDrive "C"
 CurDir ("C:\excel_rpts\")
 If region_nm = "N/A"Then region_nm = "N-A"
 Wk.SaveAs FileName:="C:\excel_rpts\" & region_nm & " " & strStamp & ".xls"
 ActiveWorkbook.Close True

 EndWithNext i
 '.AutoFilterMode = FalseEndWithSet ThisSheet =Nothing
Application.CutCopyMode =False
Application.ScreenUpdating = TrueEndSub

Not able to get out of loop - its loop within a loop

ndbhatt

New Member

Excel Facts

Tazguy37

MrExcel MVP

ndbhatt

New Member

Tazguy37

MrExcel MVP

ndbhatt

New Member

Tazguy37

MrExcel MVP

ndbhatt

New Member

Similar threads

Forum statistics

Share this page

Not able to get out of loop - its loop within a loop

ndbhatt

New Member

Excel Facts

Tazguy37

MrExcel MVP

ndbhatt

New Member

Tazguy37

MrExcel MVP

ndbhatt

New Member

Tazguy37

MrExcel MVP

ndbhatt

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock