Hello,
I developed another macro which uses an iterateing range search command instead of a pivot table. So with this one, you don't have to create a separate pivot table or create a named range. This will work straight from the orginal workbook you provided. I think the above code is well written code, I am also not claiming to be a macro expert, I am just posting all I can so I won't be a "Novice" anymore.

So with this, you do have to rename the original sheet with all your data to "Original". So rename the sheet, hit Alt + F11, and copy and paste the following code into the VB window, hit play and you are good to go:

Sub biffur()
Dim easy As Range, fnd As Range
Dim numrow As Long
Dim szstate As String, sztmp As String
Dim wrkbk As Workbook
Dim origsht As Worksheet, wrksht As Worksheet

Application.ScreenUpdating = False

Set wrkbk = ActiveWorkbook
Set origsht = wrkbk.Sheets("Original")
sztmp = origsht.Name
Set easy = origsht.Range("B2")
numrow = easy.End(xlDown).Row - 2

For i = 1 To numrow
origsht.Select
easy.Offset(i, 0).Select
szstate = ActiveCell.Value
If shtexsts(szstate) = False Then
With origsht.Range("B2:B2000")


Set fnd = .Find(szstate, LookIn:=xlValues)
If Not fnd Is Nothing Then
firstAddress = fnd.Address
Do
iter = iter + 1
Set fnd = .FindNext(fnd)
Loop While Not fnd Is Nothing And fnd.Address <> firstAddress
End If
End With
Set wrksht = wrkbk.Sheets.Add
wrksht.Move After:=Sheets(sztmp)
wrksht.Name = szstate
Range("B2").Value = "State"
Range("C2").Value = "Zone"
For j = 1 To iter
Range("B2").Offset(j, 0).Value = szstate
Next j
sztmp = szstate
End If
Next i
Application.ScreenUpdating = True
End Sub

Function shtexsts(shtnm As String) As Boolean
On Error Resume Next
shtexsts = CBool(Len(Sheets(shtnm).Name))
End Function

Regards,
Math Nerd

The attached file is the original file in which i have to implement this macro, thks jsmath n bjorns for ur help but still having problem with it. I want the first 13 rows to be same in all sheet and from O to T column i have the formula which should not be change & in ab & ac column i have the state & zone. all. the rows of data available in this file will not remain same every month it will keep on changing (either increase or decrease ). maximum rows will be 30000.

Attached Files

sample (new).zip (1.57 MB, 16 views)

Hi,
in the macro I sent you, all you have to do is to change the "Important parameters" to the following values:

FirstRow = 14
StateColumn = "AB"
DataSheet = "original"

When creating the pivot table, please mark the cells AB13:AB65535.
Then create the pivot table as explained above and just follow the previous instructions. The macro will take some time to run, but it worked when I tested it on your complete file.

Kind regards
Bjorn

Hi again,
I realized that my solution was too slow
Since I couldn't let go of the challenge I decided to try to solve it

@jsmath22: I am not trying to compete with you or anything like that. I just wanted to try to fix this on my own

Anyhow, here is a completely new version, that don't need any pivot table.

Just place the cursor in the cell where the header "State" is (AB13 in your example sheet). Then run the macro. It takes about half a minute to run it for the complete data volume.

Kind regards
Bjorn


Macro:
Sub OneSheetPerState2()
Dim rng1 As Range, rng2 As Range
Dim LastRow1 As Long, LastRow2 As Long, C As Long, Max2 As Long, StateCol As Long, StateRow As Long
Dim DataSheet As String
'Starting commands
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
DataSheet = "original"
Sheets(DataSheet).Select
StateCol = ActiveCell.Column
StateRow = ActiveCell.Row

'Optional: First delete all other sheets
'For C = Sheets.Count To 2 Step -1
' Application.DisplayAlerts = False
' Sheets(C).Delete
' Application.DisplayAlerts = True
'Next C

' Save exclusive states in table State()
With ActiveSheet
LastRow1 = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
End With

Set rng1 = ActiveSheet.Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(LastRow1, ActiveCell.Column))
ActiveCell.EntireColumn.Offset(0, 1).Insert
rng1.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveCell.Offset(0, 1), Unique:=True
With ActiveSheet
LastRow2 = .Cells(.Rows.Count, ActiveCell.Column + 1).End(xlUp).Row
End With

Set rng2 = ActiveSheet.Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(LastRow2, ActiveCell.Column + 1))
rng2.Sort Key1:=Cells(ActiveCell.Row, ActiveCell.Column + 1), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Dim State(2 To 999) As String

Max2 = rng2.Count
For C = 2 To rng2.Count
State(C) = rng2(C)
Next C
ActiveCell.EntireColumn.Offset(0, 1).Delete
' Save the long statelist in table StateListLong()
Dim StateListLong(1 To 65000) As String

For C = StateRow + 1 To LastRow1
StateListLong(C) = Cells(C, StateCol).Value
Next C
' Add one sheet per state
For C = 2 To Max2
Worksheets.Add(After:=Worksheets(Worksheets.Count) ).Name = State(C)
Sheets(DataSheet).Select
Rows("1:" & StateRow).Select
Selection.Copy
Sheets(State(C)).Select
ActiveSheet.Paste
Cells(StateRow + 1, 1).Select
Next C
Sheets(DataSheet).Select
' Copy every row from original sheet to the next free line in the proper sheet
For C = StateRow + 1 To LastRow1
Sheets(DataSheet).Select
Rows(C).Copy
temp = Cells(C, StateCol)
Sheets(temp).Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Next C
'Ending commands
Sheets(DataSheet).Select
Application.CutCopyMode = False
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Hii,
UR macro runs fine, but may I know which is the last row the macro take into account while biffurcating the file into sheets. Thanks bjorns for ur contribution for reducing effort for preparing the particular file by making valuable macro. hats off buddy.

Hi,
to know the last row of the "state column" (AB) which is taken into account, there are a number of ways to get this info.

Either extend the existing macro by:
Cells(1, 1) = LastRow1
Put this just before "End Sub", then cell A1 of the sheet "Original" will show you the value.

You can also implement the additional macro below. In this version it gives a popup-message, showing the last column of the column you have activated.
By removing the remark symbol of the command "ActiveCell.Value = LastRow1", you can also have the value written in the current cell (whatever fits you best).

Kind regards
Bjorn


Sub LastRow()
Dim LastRow1 As Long
Dim i As integer

With ActiveSheet
LastRow1 = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
End With

i = MsgBox("Last Row for this column is " & LastRow1, vbOKOnly + vbInformation)

' ActiveCell.Value = LastRow1

End Sub

When i'm using the macro it display runtime error 13. shows State(C) = rng2(C) with yellow mark. upto my knowledge the code will be having problem plz rectify this.