keilah
09-04-2007, 01:43 AM
Hi developers and gurus
i have a macro that works fine, to a teeeeee. But the only problem i am have is once the macro has run and done its job. "I want to create refresh macro that puts the data back to its original format (exact copy) before the data was nicely sort out".
Here is the macro that sorts out the data
Sub FormatMacro()
Dim c As Range
Dim rng As Range
Dim eMsg As Long
Dim sBar As Boolean
Dim LastCol As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim firstaddress As String
On Error GoTo endo
'//Change sheet name to suit
Set ws = Sheets("Accounts-")
'//end change
'//speed
With Application
sBar = .DisplayStatusBar
.DisplayStatusBar = True
.ScreenUpdating = False
End With
'//work with object
With ws
'//get last row of data Col D
LastRow = .Range("D65536").End(xlUp).Row
'//get last Col of data Row 7
LastCol = .Range("IV7").End(xlToLeft).Column
'//convert Columns J to Last Col to dates
Set rng = .Range(Cells(7, "J").Address, Cells(7, LastCol).Address)
'//bad data//
Err.Clear
On Error Resume Next
'//display
Application.StatusBar = "Formatting Date Columns..."
For Each c In rng
With c
.Value = DateSerial(Year(c), Month(c), 1)
If Err <> 0 Then
eMsg = MsgBox("Bad date at " & c.Address(0, 0) _
& vbCrLf & vbCrLf & " Aborting Sub", vbCritical)
Application.ScreenUpdating = True
ActiveSheet.ScrollColumn = c.Column
c.Select
GoTo BadDate
End If
.NumberFormat = "m/yyyy"
End With
Next c
On Error GoTo endo
'//end bad data//
'//display
Application.StatusBar = "Sorting..."
'//sort on Col H = dates 'descending'
.Range(Cells(8, 4).Address, Cells(LastRow, LastCol).Address).Sort _
Key1:=Range("H8"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'//create range object
Set rng = .Range("I8:CZ" & LastRow)
'//display
Application.StatusBar = "Replacing blanks and Zeros..."
'//replace "" and 0 with "-"
With rng
.Replace What:="", Replacement:="-", lookat:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="0", Replacement:="-", lookat:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
'//set format
.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
'//display
Application.StatusBar = "Formatting..."
'//OPTIONAL: align "-" to center//
Set c = .Find("-", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Application.StatusBar = "Formatting..."
c.HorizontalAlignment = xlCenter
Set c = .FindNext(c)
Application.StatusBar = "Formatting ..."
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
'//END OPTIONAL//
End With
'//display
Application.StatusBar = "Sorting Date Columns..."
'//sort Columns J to Last Col by date
Set rng = .Range(Cells(7, "J").Address, Cells(LastRow, LastCol).Address)
rng.Sort Key1:=Range("J7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
End With
BadDate:
'//cleanup
Set c = Nothing
Set ws = Nothing
Set rng = Nothing
'//reset
With Application
.StatusBar = False
.ScreenUpdating = True
.DisplayStatusBar = sBar
End With
'//normal exit
Exit Sub
'//errored out
endo:
'//cleanup
Set c = Nothing
Set ws = Nothing
Set rng = Nothing
eMsg = MsgBox(Err.Number & " " & Err.Description, vbCritical)
'//reset
With Application
.StatusBar = False
.ScreenUpdating = True
.DisplayStatusBar = sBar
End With
End Sub
Now I want to unsort it back to its original fomat .... an exact copy.
i have a macro that works fine, to a teeeeee. But the only problem i am have is once the macro has run and done its job. "I want to create refresh macro that puts the data back to its original format (exact copy) before the data was nicely sort out".
Here is the macro that sorts out the data
Sub FormatMacro()
Dim c As Range
Dim rng As Range
Dim eMsg As Long
Dim sBar As Boolean
Dim LastCol As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim firstaddress As String
On Error GoTo endo
'//Change sheet name to suit
Set ws = Sheets("Accounts-")
'//end change
'//speed
With Application
sBar = .DisplayStatusBar
.DisplayStatusBar = True
.ScreenUpdating = False
End With
'//work with object
With ws
'//get last row of data Col D
LastRow = .Range("D65536").End(xlUp).Row
'//get last Col of data Row 7
LastCol = .Range("IV7").End(xlToLeft).Column
'//convert Columns J to Last Col to dates
Set rng = .Range(Cells(7, "J").Address, Cells(7, LastCol).Address)
'//bad data//
Err.Clear
On Error Resume Next
'//display
Application.StatusBar = "Formatting Date Columns..."
For Each c In rng
With c
.Value = DateSerial(Year(c), Month(c), 1)
If Err <> 0 Then
eMsg = MsgBox("Bad date at " & c.Address(0, 0) _
& vbCrLf & vbCrLf & " Aborting Sub", vbCritical)
Application.ScreenUpdating = True
ActiveSheet.ScrollColumn = c.Column
c.Select
GoTo BadDate
End If
.NumberFormat = "m/yyyy"
End With
Next c
On Error GoTo endo
'//end bad data//
'//display
Application.StatusBar = "Sorting..."
'//sort on Col H = dates 'descending'
.Range(Cells(8, 4).Address, Cells(LastRow, LastCol).Address).Sort _
Key1:=Range("H8"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'//create range object
Set rng = .Range("I8:CZ" & LastRow)
'//display
Application.StatusBar = "Replacing blanks and Zeros..."
'//replace "" and 0 with "-"
With rng
.Replace What:="", Replacement:="-", lookat:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
.Replace What:="0", Replacement:="-", lookat:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
'//set format
.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
'//display
Application.StatusBar = "Formatting..."
'//OPTIONAL: align "-" to center//
Set c = .Find("-", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
Application.StatusBar = "Formatting..."
c.HorizontalAlignment = xlCenter
Set c = .FindNext(c)
Application.StatusBar = "Formatting ..."
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
'//END OPTIONAL//
End With
'//display
Application.StatusBar = "Sorting Date Columns..."
'//sort Columns J to Last Col by date
Set rng = .Range(Cells(7, "J").Address, Cells(LastRow, LastCol).Address)
rng.Sort Key1:=Range("J7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
End With
BadDate:
'//cleanup
Set c = Nothing
Set ws = Nothing
Set rng = Nothing
'//reset
With Application
.StatusBar = False
.ScreenUpdating = True
.DisplayStatusBar = sBar
End With
'//normal exit
Exit Sub
'//errored out
endo:
'//cleanup
Set c = Nothing
Set ws = Nothing
Set rng = Nothing
eMsg = MsgBox(Err.Number & " " & Err.Description, vbCritical)
'//reset
With Application
.StatusBar = False
.ScreenUpdating = True
.DisplayStatusBar = sBar
End With
End Sub
Now I want to unsort it back to its original fomat .... an exact copy.