Update
Due to the fact that the client's version of excel does not support VBA, I have moved on to a C# excel interop solution which has been reviewed.
The test data has been added at the bottom. The test file including the macros can be found at https://github.com/pacmaninbw/Anza-Tenant-Roster/RentRosterActions.xlsm.
End Update
This Excel VBA program prints a list of apartment numbers with the name of the renter(s) for the mailbox for each building of the apartment complex I live in. The user (apartment managers assistant) can select to print a mailbox list for either a single building or all the buildings in the complex at once. I chose excel VBA because the renter roster is currently stored as an excel workbook rather than in a database.
I decided to do this for the apartment building because the mailbox list for my building is at least 2 years out of date.
For 5 buildings it runs in under 30 seconds.
It has been about 8 years since I wrote any VBA code, what could I do better?
Option Explicit
Dim AddressAndApts As Worksheet
Dim AddressRange As Range
Dim RentRosterSheet As String
Private Function LastRowInColumn(ByVal sht As Worksheet, ByVal CurrentColumn As Long) As Long
LastRowInColumn = sht.Cells(sht.Rows.Count, CurrentColumn).End(xlUp).Row
End Function
Private Function LastColumnInRow(ByVal sht As Worksheet, ByVal CurretRow As Long) As Long
LastColumnInRow = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
End Function
Private Sub GetRenterData(CurrentColumn As Long, _
FirstFloorCount As Integer, SecondFloorCount As Integer, ThirdFloorCount As Integer, _
FirstFloor() As Variant, SecondFloor() As Variant, ThirdFloor() As Variant _
)
Dim AptInfoInput As Worksheet
Dim FoundCell As Range
Dim LastRow, i As Long
LastRow = LastRowInColumn(AddressAndApts, CurrentColumn)
Const AptNumberOffset As Long = 2
Const FirstRenterName As Long = 4
Const CosignerName As Long = 6
FirstFloorCount = 0
SecondFloorCount = 0
ThirdFloorCount = 0
Set AptInfoInput = ThisWorkbook.Sheets("RenterRoster")
With AptInfoInput
For i = 0 To LastRow - 1
Dim AptNumber As String
Dim AptInfo As String
AptNumber = AddressAndApts.Cells(i + AptNumberOffset, CurrentColumn)
Set FoundCell = .Range("A:A").Find(What:=AptNumber)
If Not FoundCell Is Nothing Then
Dim AptInfoRow As Long
AptInfoRow = FoundCell.Row
AptInfo = .Cells(AptInfoRow, 1).Value & " " & .Cells(AptInfoRow, FirstRenterName).Value
If Not IsEmpty(.Cells(AptInfoRow, CosignerName)) Then
AptInfo = AptInfo & " // " & .Cells(AptInfoRow, CosignerName)
End If
End If
If AptNumber < "200" Then
FirstFloor(FirstFloorCount) = AptInfo
FirstFloorCount = FirstFloorCount + 1
Else
If AptNumber < "300" Then
SecondFloor(SecondFloorCount) = AptInfo
SecondFloorCount = SecondFloorCount + 1
Else
' Add spaces to the begining to offset the third floor from the first floor
ThirdFloor(ThirdFloorCount) = " " _
& AptInfo
ThirdFloorCount = ThirdFloorCount + 1
End If
End If
Next i
End With
End Sub
Private Function FillOutputSheet(ByVal SheetName As String, _
ByVal FirstFloorCount As Integer, ByVal SecondFloorCount As Integer, ByVal ThirdFloorCount As Integer, _
FirstFloor() As Variant, SecondFloor() As Variant, ThirdFloor() As Variant _
) As Integer
Dim OutputSheet As Worksheet
Dim Max1st2nd As Integer
Dim Row As Integer
Dim i As Integer
Set OutputSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
OutputSheet.Name = SheetName
OutputSheet.Cells(1, 1).Value = SheetName
Max1st2nd = FirstFloorCount
If FirstFloorCount < SecondFloorCount Then
Max1st2nd = SecondFloorCount
End If
Row = 2
For i = 0 To Max1st2nd - 1
OutputSheet.Cells(Row, 1).Value = FirstFloor(i)
OutputSheet.Cells(Row, 2).Value = SecondFloor(i)
Row = Row + 1
Next i
Row = Row - 1
FillOutputSheet = Row
For i = 0 To ThirdFloorCount - 1
OutputSheet.Cells(Row, 1).Value = ThirdFloor(i)
Row = Row + 1
Next i
End Function
Private Sub FormatOutputSheet(SheetName As String, ByVal StartThirdFloor As Integer, _
ByVal ThirdFloorCount As Integer)
Dim OutputSheet As Worksheet
Dim OutputDataRange, TitleRange, OutputThirdFloor As Range
Dim OutputDataRangeValue, OutputThirdFloorRangeValue As String
OutputDataRangeValue = "A2:B" & (StartThirdFloor - 1)
OutputThirdFloorRangeValue = "A" & StartThirdFloor & ":B60"
Set OutputSheet = ThisWorkbook.Sheets(SheetName)
Set OutputDataRange = OutputSheet.Range(OutputDataRangeValue)
Set OutputThirdFloor = OutputSheet.Range(OutputThirdFloorRangeValue)
Set TitleRange = OutputSheet.Range("A1:B1")
Const ColumnWidth As Double = 43
Const DataRowHeight As Double = 26
OutputSheet.PageSetup.TopMargin = Application.InchesToPoints(0.5)
OutputSheet.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
With OutputSheet.Range("A1:B60")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Font.Size = 12
.Font.Bold = True
.ColumnWidth = ColumnWidth
End With
With TitleRange
.HorizontalAlignment = xlCenter
.MergeCells = True
.Font.Size = 70
.Font.Bold = True
End With
With OutputDataRange
.Cells.WrapText = True
.ColumnWidth = ColumnWidth
.RowHeight = DataRowHeight
End With
With OutputThirdFloor
.Cells.WrapText = True
.RowHeight = DataRowHeight
End With
Dim i As Integer
For i = 0 To ThirdFloorCount - 1
Dim RangeValue As String
Dim Row As Integer
Row = StartThirdFloor + i
RangeValue = "A" & Row & ":B" & Row
OutputSheet.Range(RangeValue).MergeCells = True
Next i
End Sub
' This subroutine will create and print 1 mailbox list
' It can becalled in a loop to print all the mailbox lists
Private Sub CreatePrintDeleteMailboxList(ByVal CurrentColumn As Long)
Dim FoundCell As Range
Dim LastRow, i, AptNumberOffset As Long
Dim StreetNumber As String
Dim FirstFloorCount As Integer
Dim SecondFloorCount As Integer
Dim ThirdFloorCount As Integer
Dim FirstFloor(50) As Variant
Dim SecondFloor(50) As Variant
Dim ThirdFloor(50) As Variant
Application.ScreenUpdating = False
StreetNumber = AddressAndApts.Cells(1, CurrentColumn)
If StreetNumber = "Buildings Addresses" Then
' This option generates 5 worksheets, but should not generate one for the first column
Exit Sub
End If
Call GetRenterData(CurrentColumn, FirstFloorCount, SecondFloorCount, ThirdFloorCount, FirstFloor, SecondFloor, ThirdFloor)
Dim Start3rdFloor As Integer
Start3rdFloor = FillOutputSheet(StreetNumber, FirstFloorCount, SecondFloorCount, ThirdFloorCount, FirstFloor, SecondFloor, ThirdFloor)
Call FormatOutputSheet(StreetNumber, Start3rdFloor, ThirdFloorCount)
Dim OutputSheet As Worksheet
Set OutputSheet = ThisWorkbook.Sheets(StreetNumber)
OutputSheet.PrintOut
OutputSheet.Delete
Application.ScreenUpdating = True
End Sub
Private Sub AddressToPrint_Click()
Dim StreetAddress As String
StreetAddress = AddressToPrint.List(AddressToPrint.ListIndex)
PrintListsButton.Enabled = True
SelectedPrintItem.Text = StreetAddress
End Sub
Private Sub PrintListsButton_Click()
Dim CurrentColumn As Long
If (SelectedPrintItem.Text = "All Buildings") Then
Dim LastColumn As Long
Dim i As Long
LastColumn = LastColumnInRow(AddressAndApts, 1)
LastColumn = LastColumn - 1
For i = 1 To LastColumn
CurrentColumn = i
Call CreatePrintDeleteMailboxList(CurrentColumn)
Next i
Unload Me
Else
Dim FoundCell As Range
Set FoundCell = AddressAndApts.Range("1:1").Find(What:=SelectedPrintItem.Text)
If Not FoundCell Is Nothing Then
CurrentColumn = FoundCell.Column
Call CreatePrintDeleteMailboxList(CurrentColumn)
End If
End If
End Sub
Private Sub UserForm_Activate()
Dim i As Integer
Dim LastColumn As Long
Set AddressAndApts = ThisWorkbook.Sheets("Bldgs and AppartMents")
LastColumn = LastColumnInRow(AddressAndApts, 1)
Set AddressRange = AddressAndApts.Range(AddressAndApts.Cells(1, 1), AddressAndApts.Cells(1, LastColumn))
With AddressToPrint
For i = 2 To LastColumn
.AddItem AddressRange.Cells(1, i)
Next i
End With
PrintListsButton.Enabled = False
End Sub
The Bldgs and AppartMents Data Sheet
1 Buildings Addresses 20809 20829 20909 20929 20939 All Buildings
2 Apartmetnts Apartments Apartments Apartments Apartments
3 101 117 133 149 161
4 102 118 134 150 162
5 103 119 135 151 163
6 104 120 136 152 164
7 105 121 140 153 165
8 106 122 141 154 166
9 107 123 142 155 167
10 108 124 143 156 168
11 109 125 144 157 169
12 110 126 145 158 170
13 111 127 146 159 171
14 112 128 147 160 172
15 113 129 148 249 261
16 114 130 233 250 262
17 115 131 234 251 263
18 116 132 235 252 264
19 201 217 236 253 265
20 202 218 241 254 266
21 203 219 242 255 267
22 204 220 243 256 268
23 205 221 244 257 269
24 206 222 245 258 270
25 207 223 246 259 271
26 208 224 247 260 272
27 209 225 248 350 362
28 210 226 338 351 363
29 211 227 339 352 364
30 212 228 340 353 365
31 213 229 341 356 368
32 214 230 344 357 369
33 215 231 345 358 370
34 216 232 346 359 371
35 302 322 347
36 303 323
37 304 324
38 305 325
39 308 328
40 309 329
41 310 330
42 311 331
The RentRoster WorkSheet
This is a sanitized version of the Rent Roster spread sheet, the names have been altered to protect the current tenants.
Apt abc First Name Last Name ghi Secondary Renter
101
102 FName2 LastName2
103 FName3 LastName3
104 FName4 LastName4
105 FName5 LastName5
106 FName6 LastName6
107 FName7 LastName7
108 FName8 LastName8 XX
109 FName9 LastName9
110 FName0 LastName0
111 FName11 LastName11
112 FName12 LastName12
113 FName13 LastName13 LastName
114 FName14 LastName14
115 FName15 LastName15
116 FName6 LastName6
201 FName7 LastName7
202 FName8 LastName8
203 FName9 LastName9
204 FName0 LastName0
205 FName1 LastName1
206 FName2 LastName2
207 FName3 LastName3 LastName16
208 FName4 LastName4
209 FName5 LastName5
210 FName6 LastName6
211 LongFirstName LongLastName
212 AnEvenLongerFirstName AnEvenLongerLastName
213 FName9 LastName9
214 FName0 LastName0 Tenant2Name
215 FName1 LastName1
216 FName2 LongLastName2Added Tenant2LongNameAdded
302 FName3 LastName3
303 FName4 LastName4
304 FName5 LastName5 XX
305 FName6 LastName6
308
309 FName1 LastName1 XXXXXX
310 FName2 LastName2
311 FName3 LastName3
117 FName4 LastName4
118 FName5 LastName5 XXXXX
119 FName6 LastName6
120 FName7 LastName7
121 FName8 LastName8
122 FName9 LastName9
123 FName0 LastName0
124 FName1 LastName1
125 FName2 LastName2
126 FName3 LastName3
127 FName4 LastName4
128 FName5 LastName5 XXXXXXX
129 FName6 LastName6
130 FName7 LastName7 XXX
131 FName8 LastName8
132 FName9 LastName9
217 FName0 LastName0 XXXXX
218 FName1 LastName1
219 FName2 LastName2
220 FName3 LastName3
221 FName4 LastName4
222 FName5 LastName5
223 FName6 LastName6
224 FName7 LastName7
225 FName8 LastName8
226 FName9 LastName9
227 FName0 LastName0
228 FName1 LastName1 XXXX
229 FName2 LastName2
230
231 FName2 LastName2
232 FName3 LastName3
322 FName4 LastName4 XXXX
323 FName5 LastName5
324 FName6 LastName6
325 FName7 LastName7 XXXXX
328 FName8 LastName8
329 FName9 LastName9
330 FName0 LastName0 XXXXXXXX
331 FName1 LastName1
133 FName2 LastName2
134 FName3 LastName3
135
136 FName5 LastName5
140 FName6 LastName6
141 FName7 LastName7 CCDDFFGG
142 FName8 LastName8
143
144 FName0 LastName0
145 FName1 LastName1
146 FName2 LastName2
147 FName3 LastName3 ABCDEFG
148 FName4 LastName4
233 FName5 LastName5
234 FName6 LastName6
235 FName7 LastName7
236 FName8 LastName8 XXX
241 FName9 LastName9
242 FName0 LastName0
243 FName1 LastName1
244 FName2 LastName2
245
246 FName4 LastName4
247 FName5 LastName5
248 FName6 LastName6
338 GGGXX23B ZYXWVUT ABCDE
339 FName2 LastName2
340 FName3 LastName3
341 FName4 LastName4
344 FName5 LastName5
345 FName6 LastName6
346 FName7 LastName7
347 FName8 LastName8
149 FName9 LastName9
150 FName0 LastName0
151 FName1 LastName1
152 FName2 LastName2
153 FName3 LastName3
154 FName4 LastName4
155 FName5 LastName5
156 FName6 LastName6
157 FName7 LastName7
158 FName8 LastName8
159 FName9 LastName9
160 FName0 LastName0
249 FName1 LastName1
250 FName2 LastName2
251 FName3 LastName3
252 FName4 LastName4
253 FName5 LastName5
254 FName6 LastName6
255 FName7 LastName7
256 FName8 LastName8
257 FName9 LastName9
258 FName0 LastName0
259 FName1 LastName1
260 FName2 LastName2
350 FName2 LastName2 XXXX
351 FName3 LastName3
352 FName4 LastName4 XXXXXXX
353 FName5 LastName5
356 FName8 LastName8
357 FName9 LastName9
358 FName0 LastName0 XXXXXXX
359 FName1 LastName1
161 FName2 LastName2
162 FName3 LastName3 XXXXXX
163 FName4 LastName4
164 FName5 LastName5
165 FName8 LastName8
166 FName9 LastName9
167 FName0 LastName0 XXXXX
168 FName1 LastName1
169 FName8 LastName8
170 FName9 LastName9 XXXXX
171 FName0 LastName0
172
261 FName4 LastName4
262 FName5 LastName5
263 FName6 LastName6
264 FName7 LastName7
265 FName0 LastName0
266 FName1 LastName1
267 FName2 LastName2
268 FName3 LastName3
269 FName6 LastName6
270 FName7 LastName7 XXX
271 FName8 LastName8
272 FName9 LastName9
362 FName2 LastName2
363 FName3 LastName3
364 FName4 LastName4
365 FName5 LastName5 XXXXXXXX
368 FName8 LastName8
369 FName9 LastName9
370 FName0 LastName0
371 FName1 LastName1
