Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Need help Refining a Macro & make more Robust.
Hi Everyone,
I have a macros that I would like to refine and make more robust. The macroa I have takes the sheet below and turns it into the last table. Just a little info on the first table. The first cell is B:2 , Also the sheet is proteceted and it has a subtotal. First Column Beg Bal Activity Ending P100100000 Cash 10 210 310 P100200000 AR 20 220 320 P100300000 AP 30 230 330 P100400000 Fixed Assets 40 240 340 P100500000 Inventory 50 250 350 * M101 M101 150 1150 1650 P100100000 Cash 110 310 410 P100200000 AR 120 320 420 P100300000 AP 130 330 430 P100400000 Fixed Assets 140 340 440 P100500000 Inventory 150 350 450 * M102 M102 650 1650 2150 P100100000 Cash 160 360 460 P100200000 AR 170 370 470 P100300000 AP 180 380 480 P100400000 Fixed Assets 190 390 490 P100500000 Inventory 200 400 500 * M103 M103 900 1900 2400 This is how it looks after my Macro. Date LOC ACCT Description Prior PD PD Activ Current PD M101 100100000 Cash 10 210 310 M101 100200000 AR 20 220 320 M101 100300000 AP 30 230 330 M101 100400000 Fixed Assets 40 240 340 M101 100500000 Inventory 50 250 350 M101 Total 150 1150 1650 M102 100100000 Cash 110 310 410 M102 100200000 AR 120 320 420 M102 100300000 AP 130 330 430 M102 100400000 Fixed Assets 140 340 440 M102 100500000 Inventory 150 350 450 M102 Total 650 1650 2150 M103 100100000 Cash 160 360 460 M103 100200000 AR 170 370 470 M103 100300000 AP 180 380 480 M103 100400000 Fixed Assets 190 390 490 M103 100500000 Inventory 200 400 500 M103 Total 900 1900 2400 Here is my Macro Sub NEWDATA() ' ActiveSheet.Unprotect Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Selection.RemoveSubtotal Rows("1:2").Select Range("A2").Activate Selection.Delete Shift:=xlUp Columns("C:D").Select Selection.Insert Shift:=xlToRight Selection.ColumnWidth = 17.43 Columns("B:B").Select Selection.TextToColumns Destination:=Range("B1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(15, 1)) Selection.Delete Shift:=xlToLeft Range("A1").Select 'Add Data Dim lastrow As Long Dim i As Long, loc As String Columns(1).ClearContents lastrow = Cells(Rows.Count, 2).End(xlUp).Row For i = lastrow To 1 Step -1 If IsNumeric(Cells(i, 2)) Then Cells(i, 1) = loc Else loc = Cells(i, 2) End If Next Dim rng As Range On Error Resume Next Set rng = Columns(1).SpecialCells(xlBlanks) On Error GoTo 0 If Not rng Is Nothing Then rng.EntireRow.Delete End If Columns("A:C").Select Range("C1").Activate Selection.ColumnWidth = 1.14 Columns("A:C").EntireColumn.AutoFit Columns("B:B").Select Selection.Insert Shift:=xlToRight Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(3, 1)) Columns("A:A").Select Selection.Delete Shift:=xlToLeft Rows("1:1").Select Selection.Insert Shift:=xlDown Range("A1").Select ActiveCell.FormulaR1C1 = "LOC" Range("B1").Select ActiveCell.FormulaR1C1 = "ACCT" Range("C1").Select ActiveCell.FormulaR1C1 = "DESCRIPTION" Range("D1").Select ActiveCell.FormulaR1C1 = "PRIOR PD" Range("E1").Select ActiveCell.FormulaR1C1 = "PD ACTIV." Range("F1").Select ActiveCell.FormulaR1C1 = "CURRENT PD" Rows("1:1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With Selection.Font.Bold = True Selection.Font.Underline = xlUnderlineStyleSingle Columns("A:A").Select Selection.Insert Shift:=xlToRight Range("A1").Select ActiveCell.FormulaR1C1 = "DATE" Columns("A:A").Select Selection.NumberFormat = "mmm-yy" Cells.Select Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6, 7), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True Selection.Copy Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Selection.RemoveSubtotal End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Need help Refining a Macro & make more Robust.
I have not tried your macro, but I notice that you select cells before acting
on them. This is a waste of time! Range("B1").Select ActiveCell.FormulaR1C1 = "ACCT" can be written Range("B1").VALUE = "ACCT" This will already reduce your code by almost half! Looks like you recorded this macro, which is fine, but then you have to clean up statements like "Application.CutCopyMode = False" which really serves no purpose. I do not understand the purpose of the FOR NEXT section. IF cells 1,2 is numeric, then cells i,1 is = to loc, which is nothing (""). If cells 1,2 is not numeric, then loc = cells i,2, which could then also be nothing? Maybe I read to fast? "Mascot" wrote: Hi Everyone, I have a macros that I would like to refine and make more robust. The macroa I have takes the sheet below and turns it into the last table. Just a little info on the first table. The first cell is B:2 , Also the sheet is proteceted and it has a subtotal. First Column Beg Bal Activity Ending P100100000 Cash 10 210 310 P100200000 AR 20 220 320 P100300000 AP 30 230 330 P100400000 Fixed Assets 40 240 340 P100500000 Inventory 50 250 350 * M101 M101 150 1150 1650 P100100000 Cash 110 310 410 P100200000 AR 120 320 420 P100300000 AP 130 330 430 P100400000 Fixed Assets 140 340 440 P100500000 Inventory 150 350 450 * M102 M102 650 1650 2150 P100100000 Cash 160 360 460 P100200000 AR 170 370 470 P100300000 AP 180 380 480 P100400000 Fixed Assets 190 390 490 P100500000 Inventory 200 400 500 * M103 M103 900 1900 2400 This is how it looks after my Macro. Date LOC ACCT Description Prior PD PD Activ Current PD M101 100100000 Cash 10 210 310 M101 100200000 AR 20 220 320 M101 100300000 AP 30 230 330 M101 100400000 Fixed Assets 40 240 340 M101 100500000 Inventory 50 250 350 M101 Total 150 1150 1650 M102 100100000 Cash 110 310 410 M102 100200000 AR 120 320 420 M102 100300000 AP 130 330 430 M102 100400000 Fixed Assets 140 340 440 M102 100500000 Inventory 150 350 450 M102 Total 650 1650 2150 M103 100100000 Cash 160 360 460 M103 100200000 AR 170 370 470 M103 100300000 AP 180 380 480 M103 100400000 Fixed Assets 190 390 490 M103 100500000 Inventory 200 400 500 M103 Total 900 1900 2400 Here is my Macro Sub NEWDATA() ' ActiveSheet.Unprotect Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Selection.RemoveSubtotal Rows("1:2").Select Range("A2").Activate Selection.Delete Shift:=xlUp Columns("C:D").Select Selection.Insert Shift:=xlToRight Selection.ColumnWidth = 17.43 Columns("B:B").Select Selection.TextToColumns Destination:=Range("B1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(15, 1)) Selection.Delete Shift:=xlToLeft Range("A1").Select 'Add Data Dim lastrow As Long Dim i As Long, loc As String Columns(1).ClearContents lastrow = Cells(Rows.Count, 2).End(xlUp).Row For i = lastrow To 1 Step -1 If IsNumeric(Cells(i, 2)) Then Cells(i, 1) = loc Else loc = Cells(i, 2) End If Next Dim rng As Range On Error Resume Next Set rng = Columns(1).SpecialCells(xlBlanks) On Error GoTo 0 If Not rng Is Nothing Then rng.EntireRow.Delete End If Columns("A:C").Select Range("C1").Activate Selection.ColumnWidth = 1.14 Columns("A:C").EntireColumn.AutoFit Columns("B:B").Select Selection.Insert Shift:=xlToRight Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(3, 1)) Columns("A:A").Select Selection.Delete Shift:=xlToLeft Rows("1:1").Select Selection.Insert Shift:=xlDown Range("A1").Select ActiveCell.FormulaR1C1 = "LOC" Range("B1").Select ActiveCell.FormulaR1C1 = "ACCT" Range("C1").Select ActiveCell.FormulaR1C1 = "DESCRIPTION" Range("D1").Select ActiveCell.FormulaR1C1 = "PRIOR PD" Range("E1").Select ActiveCell.FormulaR1C1 = "PD ACTIV." Range("F1").Select ActiveCell.FormulaR1C1 = "CURRENT PD" Rows("1:1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With Selection.Font.Bold = True Selection.Font.Underline = xlUnderlineStyleSingle Columns("A:A").Select Selection.Insert Shift:=xlToRight Range("A1").Select ActiveCell.FormulaR1C1 = "DATE" Columns("A:A").Select Selection.NumberFormat = "mmm-yy" Cells.Select Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6, 7), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True Selection.Copy Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Selection.RemoveSubtotal End Sub |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Need help Refining a Macro & make more Robust.
Hi Kassie,
I got that macro from a previous thread. Here is the link. http://www.microsoft.com/office/comm...xp=&sloc=en-us Thanks Mascot "kassie" wrote: I have not tried your macro, but I notice that you select cells before acting on them. This is a waste of time! Range("B1").Select ActiveCell.FormulaR1C1 = "ACCT" can be written Range("B1").VALUE = "ACCT" This will already reduce your code by almost half! Looks like you recorded this macro, which is fine, but then you have to clean up statements like "Application.CutCopyMode = False" which really serves no purpose. I do not understand the purpose of the FOR NEXT section. IF cells 1,2 is numeric, then cells i,1 is = to loc, which is nothing (""). If cells 1,2 is not numeric, then loc = cells i,2, which could then also be nothing? Maybe I read to fast? "Mascot" wrote: Hi Everyone, I have a macros that I would like to refine and make more robust. The macroa I have takes the sheet below and turns it into the last table. Just a little info on the first table. The first cell is B:2 , Also the sheet is proteceted and it has a subtotal. First Column Beg Bal Activity Ending P100100000 Cash 10 210 310 P100200000 AR 20 220 320 P100300000 AP 30 230 330 P100400000 Fixed Assets 40 240 340 P100500000 Inventory 50 250 350 * M101 M101 150 1150 1650 P100100000 Cash 110 310 410 P100200000 AR 120 320 420 P100300000 AP 130 330 430 P100400000 Fixed Assets 140 340 440 P100500000 Inventory 150 350 450 * M102 M102 650 1650 2150 P100100000 Cash 160 360 460 P100200000 AR 170 370 470 P100300000 AP 180 380 480 P100400000 Fixed Assets 190 390 490 P100500000 Inventory 200 400 500 * M103 M103 900 1900 2400 This is how it looks after my Macro. Date LOC ACCT Description Prior PD PD Activ Current PD M101 100100000 Cash 10 210 310 M101 100200000 AR 20 220 320 M101 100300000 AP 30 230 330 M101 100400000 Fixed Assets 40 240 340 M101 100500000 Inventory 50 250 350 M101 Total 150 1150 1650 M102 100100000 Cash 110 310 410 M102 100200000 AR 120 320 420 M102 100300000 AP 130 330 430 M102 100400000 Fixed Assets 140 340 440 M102 100500000 Inventory 150 350 450 M102 Total 650 1650 2150 M103 100100000 Cash 160 360 460 M103 100200000 AR 170 370 470 M103 100300000 AP 180 380 480 M103 100400000 Fixed Assets 190 390 490 M103 100500000 Inventory 200 400 500 M103 Total 900 1900 2400 Here is my Macro Sub NEWDATA() ' ActiveSheet.Unprotect Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Selection.RemoveSubtotal Rows("1:2").Select Range("A2").Activate Selection.Delete Shift:=xlUp Columns("C:D").Select Selection.Insert Shift:=xlToRight Selection.ColumnWidth = 17.43 Columns("B:B").Select Selection.TextToColumns Destination:=Range("B1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(15, 1)) Selection.Delete Shift:=xlToLeft Range("A1").Select 'Add Data Dim lastrow As Long Dim i As Long, loc As String Columns(1).ClearContents lastrow = Cells(Rows.Count, 2).End(xlUp).Row For i = lastrow To 1 Step -1 If IsNumeric(Cells(i, 2)) Then Cells(i, 1) = loc Else loc = Cells(i, 2) End If Next Dim rng As Range On Error Resume Next Set rng = Columns(1).SpecialCells(xlBlanks) On Error GoTo 0 If Not rng Is Nothing Then rng.EntireRow.Delete End If Columns("A:C").Select Range("C1").Activate Selection.ColumnWidth = 1.14 Columns("A:C").EntireColumn.AutoFit Columns("B:B").Select Selection.Insert Shift:=xlToRight Columns("A:A").Select Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(3, 1)) Columns("A:A").Select Selection.Delete Shift:=xlToLeft Rows("1:1").Select Selection.Insert Shift:=xlDown Range("A1").Select ActiveCell.FormulaR1C1 = "LOC" Range("B1").Select ActiveCell.FormulaR1C1 = "ACCT" Range("C1").Select ActiveCell.FormulaR1C1 = "DESCRIPTION" Range("D1").Select ActiveCell.FormulaR1C1 = "PRIOR PD" Range("E1").Select ActiveCell.FormulaR1C1 = "PD ACTIV." Range("F1").Select ActiveCell.FormulaR1C1 = "CURRENT PD" Rows("1:1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .ShrinkToFit = False .MergeCells = False End With Selection.Font.Bold = True Selection.Font.Underline = xlUnderlineStyleSingle Columns("A:A").Select Selection.Insert Shift:=xlToRight Range("A1").Select ActiveCell.FormulaR1C1 = "DATE" Columns("A:A").Select Selection.NumberFormat = "mmm-yy" Cells.Select Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6, 7), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True Selection.Copy Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Selection.RemoveSubtotal End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Need help refining this formula | Excel Discussion (Misc queries) | |||
Help refining sumproduct | Excel Discussion (Misc queries) | |||
Copying Charts: CODE NOT ROBUST | Excel Programming | |||
Refining Countif | Excel Discussion (Misc queries) | |||
Can someone help me make this code more robust? | Excel Programming |