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

All in all it is not too bad and if it works then you really don't need to
worry about making changes. If it ain't broke then don't fix it. That being
said to find the first unused row you can use code like this

cells(rows.count, "A").end(xlup).offset(1,0).select

To find out if a sheet exists here is a simple function.
Public Function SheetExists(SName As String, _
Optional ByVal Wb As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If Wb Is Nothing Then Set Wb = ThisWorkbook
SheetExists = CBool(Len(Wb.Sheets(SName).Name))
End Function

Which is used like this

if sheetExist("Sheet1") = true then msgbox "Sheet1 Exists"



--
HTH...

Jim Thomlinson


"P51D Mustang" wrote:

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 junk
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

Thanks for the quick reply....The "don't fix what isn't broke" philosophy is
surely good adivce!

The function looks like a keeper, too.

Thx again

Kirby



"Jim Thomlinson" wrote:

All in all it is not too bad and if it works then you really don't need to
worry about making changes. If it ain't broke then don't fix it. That being
said to find the first unused row you can use code like this

cells(rows.count, "A").end(xlup).offset(1,0).select

To find out if a sheet exists here is a simple function.
Public Function SheetExists(SName As String, _
Optional ByVal Wb As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If Wb Is Nothing Then Set Wb = ThisWorkbook
SheetExists = CBool(Len(Wb.Sheets(SName).Name))
End Function

Which is used like this

if sheetExist("Sheet1") = true then msgbox "Sheet1 Exists"



--
HTH...

Jim Thomlinson