![]() |
#2
|
|||
|
|||
![]()
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 |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Creating a MACRO | Nikb3522 | Word VBA | 0 | 10-21-2010 05:55 PM |
![]() |
diegogeid | Excel | 2 | 09-30-2010 12:19 AM |
creating macro | steveb | Word VBA | 0 | 08-14-2010 01:29 AM |
![]() |
nolesca | Excel | 4 | 06-07-2010 08:13 AM |