Need help Refining a Macro & make more Robust.

[Mascot]

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").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

 

[kassie]

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]

Hi Kassie,

I got that macro from a previous thread. Here is the link.

http://www.microsoft.com/office/com...5298&catlist=&dglist=&ptlist=&exp=&sloc=en-us

Thanks
Mascot