M
mwilliams1216
I have the following code running to create a mail merge file. The
Users sheet contains all the contact information. The FreeAccess sheet
contains the users' IDs and the contents for the mail merge fields.
There could be as many as 30 rows per user on this sheet. The code
searches for all the rows for each user on the Users sheet and copies
the contents of each row of the FreeAccess sheets for that user to the
user's single row on the Users sheet. The problem I'm running into is
that I can run 250 records in about 15 minutes. It will run 500
records in an hour and 1000 records in 4 hours. At this point it's
quicker for me to run these in batches of 250. Is there something I
can do to stop this exponential increase in processing time so that I
can run larger batches more efficiently?
Dim lngUserRow As Long
Dim lngAccessRow As Long
Dim lngcolumn As Long
Dim lngKOU As Long
Dim lngMaxColumn As Long
Dim lngBrokerCount As Long
Dim StrHeading As String
Dim lngUserCount As Long
Dim lngAccessCount As Long
Dim n As Long
Dim lngNewMaxColumn As Long
Dim LastRow As Long
Dim strBroker As String
'Get count of users with request responses.
Worksheets("Users").Activate
If Cells(3, 1) = "" Then
lngUserCount = 1
Else: Cells(2, 1).Select
Range(Selection, Selection.End(xlDown)).Select
lngUserCount = Selection.Count
End If
' Get count of accessible brokers.
Worksheets("Free Access").Activate
Cells(2, 1).Select
Range(Selection, Selection.End(xlDown)).Select
lngAccessCount = Selection.Count
'Get accessible brokers and match them up with the users on the Users
worksheet (in one row).
Worksheets("Free Access").Activate
Cells(2, 1).Select
Selection.End(xlDown).Select
LastRow = ActiveCell.Row
lngMaxColumn = 6
lngUserRow = 2
For lngUserRow = 2 To LastRow
Worksheets("Users").Activate
lngcolumn = 7
lngKOU = Cells(lngUserRow, 1).Value
For lngAccessRow = 2 To lngAccessCount + 1
Worksheets("Free Access").Activate
If Cells(lngAccessRow, 1).Value = lngKOU Then
strBroker = Cells(lngAccessRow, 2).Value
Worksheets("Users").Activate
Cells(lngUserRow, lngcolumn).Value = strBroker
lngcolumn = lngcolumn + 1
If lngcolumn > lngMaxColumn Then
lngMaxColumn = lngcolumn
End If
End If
If IsEmpty(Cells(3, 1)) Then
GoTo FINISH_HERE
End If
Next lngAccessRow
Next lngUserRow
Users sheet contains all the contact information. The FreeAccess sheet
contains the users' IDs and the contents for the mail merge fields.
There could be as many as 30 rows per user on this sheet. The code
searches for all the rows for each user on the Users sheet and copies
the contents of each row of the FreeAccess sheets for that user to the
user's single row on the Users sheet. The problem I'm running into is
that I can run 250 records in about 15 minutes. It will run 500
records in an hour and 1000 records in 4 hours. At this point it's
quicker for me to run these in batches of 250. Is there something I
can do to stop this exponential increase in processing time so that I
can run larger batches more efficiently?
Dim lngUserRow As Long
Dim lngAccessRow As Long
Dim lngcolumn As Long
Dim lngKOU As Long
Dim lngMaxColumn As Long
Dim lngBrokerCount As Long
Dim StrHeading As String
Dim lngUserCount As Long
Dim lngAccessCount As Long
Dim n As Long
Dim lngNewMaxColumn As Long
Dim LastRow As Long
Dim strBroker As String
'Get count of users with request responses.
Worksheets("Users").Activate
If Cells(3, 1) = "" Then
lngUserCount = 1
Else: Cells(2, 1).Select
Range(Selection, Selection.End(xlDown)).Select
lngUserCount = Selection.Count
End If
' Get count of accessible brokers.
Worksheets("Free Access").Activate
Cells(2, 1).Select
Range(Selection, Selection.End(xlDown)).Select
lngAccessCount = Selection.Count
'Get accessible brokers and match them up with the users on the Users
worksheet (in one row).
Worksheets("Free Access").Activate
Cells(2, 1).Select
Selection.End(xlDown).Select
LastRow = ActiveCell.Row
lngMaxColumn = 6
lngUserRow = 2
For lngUserRow = 2 To LastRow
Worksheets("Users").Activate
lngcolumn = 7
lngKOU = Cells(lngUserRow, 1).Value
For lngAccessRow = 2 To lngAccessCount + 1
Worksheets("Free Access").Activate
If Cells(lngAccessRow, 1).Value = lngKOU Then
strBroker = Cells(lngAccessRow, 2).Value
Worksheets("Users").Activate
Cells(lngUserRow, lngcolumn).Value = strBroker
lngcolumn = lngcolumn + 1
If lngcolumn > lngMaxColumn Then
lngMaxColumn = lngcolumn
End If
End If
If IsEmpty(Cells(3, 1)) Then
GoTo FINISH_HERE
End If
Next lngAccessRow
Next lngUserRow