Hi,
I am a macro beginner, but like challanges. Here is a macro that does the job for you. Perhaps it is not the nicest macro (if an experienced vba-user would look at it, but at least it works and that is what is important).
Before you run it you have to do some manual preparations. I didn't implement them in the macro because of high complexity (for me) and since doing it manual is hardly no effort at all (at least after you have done it the first time).
Preparations:
First rename your sheet with raw data by calling it "input".
Then you must create a range in a separate sheet, containing all possible values for "State". Perhaps you already have this available (exact spelling is important), then you can just skip the text below regarding pivot table.
Create a pivot table by marking cells B2:C65535 (in sheet "input") and use "state" as both "Row-data" and "Data field" (this will calculate "Number of states per state"). If this is the second time, just update the pivot table and sort it if you like.
Running the macro:
Mark the cells (in the pivot table or wherever you have it) that now contains the exclusive rows with states. See my example sheet "pivot".
Now run the macro below and the job is done!
The macro creates sheets in the same orders as the cells with marked states, copies all data from the sheet "input" into the "just-created-state-sheet". Then it deletes every row where the state is not equal to the sheet name.
As you see the macro contains some parameters that you can change if you like.
Kind regards
Bjorn
Macro:
Sub OneStatePerSheet()
Application.ScreenUpdating = False
Dim ActSheet As Worksheet
Dim SelRange As Range
Dim C As Range
Dim LastRow As Long
Dim FirstRow As Long
Dim CurrRow As Long
Dim StateRow As String
Dim DataSheet As String
Dim PivotSheet As String
Set ActSheet = ActiveSheet
Set SelRange = Selection
' Important parameters:
FirstRow = 3
StateColumn = "B"
DataSheet = "Input"
For Each C In SelRange
Worksheets.Add(After:=Worksheets(Worksheets.Count) ).Name = C.Value
Sheets(DataSheet).Select
Cells.Select
Selection.Copy
Sheets(C.Value).Select
ActiveSheet.Paste
Range("A1").Select
With ActiveSheet
LastRow = .Cells(.Rows.Count, StateColumn).End(xlUp).Row
End With
CurrRow = LastRow
Do While CurrRow >= FirstRow
If Cells(CurrRow, StateColumn).Value <> C.Value Then Cells(CurrRow, StateColumn).EntireRow.Delete
CurrRow = CurrRow - 1
Loop
Next C
Sheets(DataSheet).Select
Application.CutCopyMode = False
Range("A1").Select
ActSheet.Select
SelRange.Select
Application.ScreenUpdating = True
End Sub
|