#1
|
||||
|
||||
creating macro for biffurcation in sheets according to data.
I have data containing column of zone (i.e state). I want that the sheet should diffurcate into sheets according to the states & also mentioning tha name of sheet according to the data (i.e if the data is of andhra pradesh, then the name of sheet should be andhra pradesh). The sample data of raw & result file is attached. the no of rows will be flexible & minimum rows will be 20000. the data of states will also change monthly. Thanks in advance. |
#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 |
#3
|
|||
|
|||
Without a pivot table
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 |
#4
|
||||
|
||||
some problem in macro
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.
|
#5
|
|||
|
|||
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 |
#6
|
|||
|
|||
Completely new solution
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 |
#7
|
||||
|
||||
Thanks for macro
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. |
#8
|
|||
|
|||
Last row...
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 |
#9
|
||||
|
||||
Error
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.
|
Thread Tools | |
Display Modes | |
|
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 |