![]() |
|
|
|
#1
|
|||
|
|||
|
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 |
|
#2
|
||||
|
||||
|
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. |
|
#3
|
|||
|
|||
|
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 |
|
#4
|
||||
|
||||
|
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.
|
|
|
|
Similar Threads
|
||||
| Thread | Thread Starter | Forum | Replies | Last Post |
| Creating a MACRO | Nikb3522 | Word VBA | 0 | 10-21-2010 05:55 PM |
How to syncronize data in two different sheets
|
diegogeid | Excel | 2 | 09-30-2010 12:19 AM |
| creating macro | steveb | Word VBA | 0 | 08-14-2010 01:29 AM |
How do I merge data from one sheet in a workbook out into multiple sheets
|
nolesca | Excel | 4 | 06-07-2010 08:13 AM |