P
P51D Mustang
I have a data area bounded by the range C1:AK451 (current month example)
The columns rarely change, the rows vary each month, but can never be
greater than 500 records due to the fixed named ranges used in the source
worksheet.
Every month I copy the same data to a new sheet, delete the same columns,
and pass (the new worksheet) out to my coworkers as a lookup list.
The following is functional, but I have no doubt there's a better way...if
some kind soul who actually knows what they're doing would take a look with a
view to giving me pointers as to where I can improve, I'd be eternally
grateful.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ListIn()
Dim LastRow As Integer
Dim LastCol As Integer
Dim WS As Worksheet
Dim newSN As String
newSN = "Alpha"
'Only run this on the Data tab
'Sheet codename has been changed to Data
Data.Select
'Display a please wait message
With Data.Shapes("Rectangle 44")
.Visible = msoTrue
End With
LastRow = Data.Range("C1").End(xlDown).Row
LastCol = Range("C1").End(xlToRight).Column
Application.ScreenUpdating = False
'Check if the List sheet already exists
For Each WS In Worksheets
If WS.Name = newSN Or newSN = "" Or IsNumeric(newSN) Then
MsgBox "Sheet already exists or name is invalid", vbInformation
With Data.Shapes("Rectangle 44")
.Visible = msoFalse
End With
Exit Sub
End If
Next
'Copy the Data worksheet to the end
Data.Copy after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = newSN
'Delete extraneous jun
Range("A:A,B:B,H:H,J:J,K:K,L:L,Q:Q,R:R,U:U,V:V,Y:Y,Z:Z,AA:AA,AB:AB,AC:AC,AD:AD,AE:AE,AF:AF,AG:AG," _
& "AH:AH,AI:AI,AJ:AJ,AK:AK,AL:AL").Delete
Rows("502:540").Delete Shift:=xlUp
Cells.FormatConditions.Delete
'Deletes some shapes used as hyperlinks within the workbook
With ActiveSheet
.DrawingObjects.Visible = True
.DrawingObjects.Delete
End With
'Find the first unused column
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.Value = "RenewalMo"
ActiveCell.Offset(1, 0).Select
With ActiveCell
.FormulaR1C1 = "=MONTH(RC[-2])"
.Copy
End With
Range("O2:O501").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Sort Key1:=Range("O2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("F2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortTextAsNumbers
Range("A1").Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
'Format the column headings
With Selection
'1 Black
'2 White
'19 Tan
'24 Pale Lavendar
'34 Pastel blue
'35 Pale Green
'39 Lavendar
'38 Rose
'37 Pale Blue
'36 Light Yellow
'41 Blue
.Interior.ColorIndex = 41
.Font.ColorIndex = 2
.Font.Bold = True
End With
With Data.Shapes("Rectangle 44")
.Visible = msoFalse
End With
'Zero out the prior month's Tenant Rent collections
Range("TRRecd").Value = 0
Range("B2").Select
ActiveWindow.FreezePanes = True
Range("A2").Select
Application.ScreenUpdating = True
End Sub
The columns rarely change, the rows vary each month, but can never be
greater than 500 records due to the fixed named ranges used in the source
worksheet.
Every month I copy the same data to a new sheet, delete the same columns,
and pass (the new worksheet) out to my coworkers as a lookup list.
The following is functional, but I have no doubt there's a better way...if
some kind soul who actually knows what they're doing would take a look with a
view to giving me pointers as to where I can improve, I'd be eternally
grateful.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ListIn()
Dim LastRow As Integer
Dim LastCol As Integer
Dim WS As Worksheet
Dim newSN As String
newSN = "Alpha"
'Only run this on the Data tab
'Sheet codename has been changed to Data
Data.Select
'Display a please wait message
With Data.Shapes("Rectangle 44")
.Visible = msoTrue
End With
LastRow = Data.Range("C1").End(xlDown).Row
LastCol = Range("C1").End(xlToRight).Column
Application.ScreenUpdating = False
'Check if the List sheet already exists
For Each WS In Worksheets
If WS.Name = newSN Or newSN = "" Or IsNumeric(newSN) Then
MsgBox "Sheet already exists or name is invalid", vbInformation
With Data.Shapes("Rectangle 44")
.Visible = msoFalse
End With
Exit Sub
End If
Next
'Copy the Data worksheet to the end
Data.Copy after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = newSN
'Delete extraneous jun
Range("A:A,B:B,H:H,J:J,K:K,L:L,Q:Q,R:R,U:U,V:V,Y:Y,Z:Z,AA:AA,AB:AB,AC:AC,AD:AD,AE:AE,AF:AF,AG:AG," _
& "AH:AH,AI:AI,AJ:AJ,AK:AK,AL:AL").Delete
Rows("502:540").Delete Shift:=xlUp
Cells.FormatConditions.Delete
'Deletes some shapes used as hyperlinks within the workbook
With ActiveSheet
.DrawingObjects.Visible = True
.DrawingObjects.Delete
End With
'Find the first unused column
Range("A1").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.Value = "RenewalMo"
ActiveCell.Offset(1, 0).Select
With ActiveCell
.FormulaR1C1 = "=MONTH(RC[-2])"
.Copy
End With
Range("O2:O501").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Sort Key1:=Range("O2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("F2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortTextAsNumbers
Range("A1").Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
'Format the column headings
With Selection
'1 Black
'2 White
'19 Tan
'24 Pale Lavendar
'34 Pastel blue
'35 Pale Green
'39 Lavendar
'38 Rose
'37 Pale Blue
'36 Light Yellow
'41 Blue
.Interior.ColorIndex = 41
.Font.ColorIndex = 2
.Font.Bold = True
End With
With Data.Shapes("Rectangle 44")
.Visible = msoFalse
End With
'Zero out the prior month's Tenant Rent collections
Range("TRRecd").Value = 0
Range("B2").Select
ActiveWindow.FreezePanes = True
Range("A2").Select
Application.ScreenUpdating = True
End Sub