A loop that assembles an Excel sheet by assembling matches from other sheets

Question

I have the following VB macro, which works fine, but the problem is one section of the macro which is this for loop (in bold), which is reading the cell value in the selection, and then looking in all sheets in the WB to find the match, and then insert that row into that sheet and then exiting and going to next cell. The problem is that if there is 40 or 45 sheets and 10000 cells, this process can take quite a while (too long for my liking !). I guess I want to know if there is a quicker way to process this, or a way that lightens the workload of the VB engine.

I was thinking of using a Scripting dictionary object, but wasn't sure if this would improve efficiency?

Sub NewSheetForSelectionValues()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim wb As Workbook
Dim cell As Range
Dim a As String
Dim i As Integer
Dim h As Range
Dim toprow As Integer
Set wb = ActiveWorkbook
Set ws = wb.Worksheets(1)
a = Selection.Address
Set h = ws.Rows("1:" & ws.Range(a).Offset(-1, 0).Row)
toprow = ws.Range(a).Row
''MsgBox Selection.Address & vbLf & wb.Name & vbLf & ws.Name & vbLf & a & vbLf & h.Address & vbLf & toprow
On Error GoTo ext
 'restricting selection
 If Selection.Count <= 20000 Then
 For Each cell In ws.Range(a)
 'cell must not be blank
 If cell <> vbNullString Then
 'disregarding of duplicates beyond the unique entry
 If Evaluate("COUNTIF(" & Left(a, 4) & ":" & Left(a, 2) & cell.Row & "," & Left(a, 2) & cell.Row & ")") = 1 Then
 ' MsgBox Evaluate("COUNTIF(" & CStr(Left(a, 4)) & ":" & Left(a, 2) & cell.Row & "," & Left(a, 2) & cell.Row & ")")
 'add the new sheet after the last sheet and paste the row
 Sheets.Add after:=Sheets(wb.Sheets.Count)
 'rename the sheet name to the value of cell
 Sheets(wb.Sheets.Count).Name = Trim(cell.Value)
 On Error GoTo 0
 'go back to the selection cell
 Application.Goto Sheets(1).Range(cell.Address)
 End If
 End If
 Next cell
 Else:
 MsgBox "Count greater than 20000 maximum!", vbOKOnly, Time
 Exit Sub
 End If
''copy each of the lines of the selection to corresponding tabs
'THIS IS THE SLOW PART OF THE SCRIPT
For Each cell In ws.Range(a)
 cell.EntireRow.Copy
 For i = 1 To wb.Sheets.Count
 If Sheets(i).Name = Trim(cell.Value) Then
 ' MsgBox "found it"
 With Sheets(i)
 .Rows(toprow).Insert
 ' .Paste
 End With
 Exit For
 End If
 Next i
' End If
Next cell
Application.CutCopyMode = False
''copy the header onto each sheet
'
ws.Activate
h.Copy
 For i = 2 To wb.Sheets.Count
 With Sheets(i)
 .Activate
 .Paste
 End With
 Next i
Application.CutCopyMode = False
'autofit col & row
'Application.Run "PERSONAL.XLSB!Sort_Active_Book"
'clear memory
Set wb = Nothing
Set ws = Nothing
Set cell = Nothing
'Call next sub
Call SeparateTabsIntoWorkbooks
'call last sub
Call SaveFilestoDesktop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ext:
Application.DisplayAlerts = False
MsgBox err.Number & " " & err.Description, vbCritical + vbDefaultButton1, "Sheet name already exists!"
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub SeparateTabsIntoWorkbooks()
'move all sheets based on selection into new workbooks with the name equal to the worksheet name
'MsgBox "Sub 3 run"
Dim i As Long
Dim wb As Workbook
Dim wbn As String
Dim wk As Worksheet
Dim moved As Integer
Set wb = ActiveWorkbook
wbn = wb.Name
 On Error GoTo erm
 For i = 2 To (wb.Sheets.Count)
 If Sheets(i - moved).Visible = xlSheetVisible Then
 With Sheets(i - moved)
 .Columns.AutoFit
 .Rows.AutoFit
 .Move
 End With
 Application.CutCopyMode = False
 End If
 Workbooks(wbn).Activate
 moved = moved + 1
 Next i
Exit Sub
erm:
MsgBox err.Number & Space(2) & err.Description
err.Clear
MsgBox err.Number & Space(2) & err.Description
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub
Sub SaveFilestoDesktop()
'MsgBox "sub 4 run"
Dim wb As Workbook
Dim wks As String
Dim sjt As String
sjt = InputBox("Subject of E-mail", "Notes.")
On Error GoTo errhandlr
 For Each wb In Workbooks
 wks = wb.ActiveSheet.Name
 If Left(wb.Name, 4) = "Book" Then
 With wb
 .SaveAs Filename:=Application.DefaultFilePath & "\" & wb.Worksheets(1).Name & "- " & VBA.FormatDateTime(Date, vbLongDate), FileFormat:=51
 .SendMail Recipients:=Right(wks, Len(wks) - WorksheetFunction.Find(",", wks) - 1) & "_" & _
 Left(wks, WorksheetFunction.Find(",", wks) - 1) & "@quadra.ca", Subject:=sjt, ReturnReceipt:=True
 .Close
 End With
'' For Each wks In wb.Worksheets
''
'' MsgBox wks.Name
'' MsgBox wb.Name
''
'' Next wks
 End If
 Next wb
'e-mail workbooks to users based on newly created WB's and append the date at the end, as well as saving a copy to desktop
Exit Sub
errhandlr:
MsgBox err.Number & Space(2) & err.Description
err.Clear
MsgBox err.Number & Space(2) & err.Description
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

• FreeMan: It would be good to post the entire Sub. You have On Error Goto ext, but your error handler isn't shown.
• Mike Mirabelli: Updated with entire script. Note that I know it's not recommended to use the "call" method , but really the main concern if the second For..next loop which takes a long time
• Mike Mirabelli: I successfuly added a scripting dictionary with all the cells as key's, but don't know how to do a test and work it into the code (ex. if dict.exists(...) = sheet name...)
• FreeMan: The first thing you could do would be to indent your code properly. That will help significantly with readability. Rubberduck is a great open-source VBE add-in that will do it for you, as well as help with a lot of other VBA issues.
• user109261: Why does the user select a range before running the macro? What is the shape of the selection? It appears the the the selection is a column of data and that you are looking for duplicates of an unique ID in the same row. Can you provide screenshots of data and/or a download link?

Answer 1

I changed the code as you can see above in the "copy each of the lines of the selection to corresponding tabs (in order of dict key)" section, that I created a scripting dictionary object in the first loop which added the values and a counter as the item.

I then referenced this in my second loop to go through each worksheet and copy paste based on the range of rows that meet the cell selection criteria. So it puts the rows as a string, splits in into a new string if over 255 char and copy pastes onto the corresponding key (tab). Overall about 10x faster.

Option Explicit
Sub NewSheetForSelectionValues()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim wb As Workbook
Dim cell As Range
Dim a As String
Dim i As Integer
Dim b As Integer
Dim h As Range
Dim toprow As Integer
Dim dict As Scripting.Dictionary
Dim key As Variant
Dim yn As Boolean
Dim srt As Date
Dim fin As Date
Dim j As Integer
Dim x As Integer
Dim rowt As Long
'testing array
Dim cRow(100) As String
Dim m As Integer
Dim z As Integer
Set dict = New Scripting.Dictionary
Set wb = ActiveWorkbook
Set ws = wb.Worksheets(1)
a = Selection.Address
Set h = ws.Rows("1:" & ws.Range(a).Offset(-1, 0).Row)
toprow = ws.Range(a).Row
srt = Now
j = 2
x = 2
On Error GoTo ext
'*************************************************************************
'Create the tabs
'*********************************************************************
If Range(a).Columns.Count = 1 Then
 For Each cell In ws.Range(a)
 'cell must not be blank
 If (cell <> vbNullString) Then 'Or Not cell Like "*,*") Then
 'disregarding of duplicates beyond the unique entry
 If Evaluate("COUNTIF(" & Left(a, 4) & ":" & Left(a, 2) & cell.Row & "," & Left(a, 2) & cell.Row & ")") = 1 Then
 ' MsgBox Evaluate("COUNTIF(" & CStr(Left(a, 4)) & ":" & Left(a, 2) & cell.Row & "," & Left(a, 2) & cell.Row & ")")
 'adds to script dictionary
 dict.Add key:=Trim(cell), Item:=j
 j = j + 1
 'add the new sheet after the last sheet and paste the row
 Sheets.Add after:=Sheets(wb.Sheets.Count)
 'rename the sheet name to the value of cell
 Sheets(wb.Sheets.Count).Name = Trim(cell.Value)
 On Error GoTo 0
 'go back to the selection cell
 Application.GoTo Sheets(1).Range(cell.Address)
 End If
 ElseIf (cell = vbNullString) Then
 If Evaluate("COUNTBLANK(" & Left(a, 4) & ":" & Left(a, 2) & cell.Row & ")") = 1 Then
 dict.Add key:="", Item:=j
 j = j + 1
 Sheets.Add after:=Sheets(wb.Sheets.Count)
 Sheets(wb.Sheets.Count).Name = " "
 On Error GoTo 0
 Application.GoTo Sheets(1).Range(cell.Address)
 End If
 End If
 Next cell
 Else:
 MsgBox "Must be single column selection!", vbInformation
 Exit Sub
End If
'******************************************************************************************
''copy the header onto each sheet
'***********************************************************************************
With ws
.Activate
 For i = 2 To wb.Sheets.Count
 h.Copy
 With Sheets(i)
 .Activate
 .Paste
 End With
 Application.CutCopyMode = False
 Next i
.Activate
End With
'**********************************************************************************
''copy each of the lines of the selection to corresponding tabs (in order of dict key)
'********************************************************************************
For Each key In dict.Keys
m = 0: z = 0
'MsgBox key & " " & dict(key)
 For Each cell In ws.Range(a)
 If Trim(cell) = key Then '
 If Len(cRow(m)) > (255 - Len(cell.Row & ":" & cell.Row & ",")) Then 'Trapping length (new array if over limit)
 m = m + 1
 cRow(m) = cRow(m) & cell.Row & ":" & cell.Row & ","
 'Range(Left(cRow(m), Len(cRow(m)) - 1)).Copy
 Else
 cRow(m) = cRow(m) & cell.Row & ":" & cell.Row & ","
 'Range(Left(cRow(m), Len(cRow(m)) - 1)).Copy
 End If '_ Destination:=wb.Sheets(dict(key)).Range(Left(cRow, Len(cRow) - 1))
 Else
 cRow(m) = cRow(m)
 End If
 'MsgBox cRow
 Next cell
 ' Debug.Print "cRow(0) " & cRow(0) & vbLf & "cRow(1) " & cRow(1) & vbLf & "cRow(2) " & cRow(2) & vbLf & "cRow(3) " & cRow(3)
 '****LOOP THROUGH ARRAYS OF TEXT AND PASTING*********
 '****************************************
For z = 0 To m
 ws.Range(Left(cRow(z), Len(cRow(z)) - 1)).Copy 'copy the rows from source sheet
 With Worksheets(dict(key))
 rowt = .UsedRange.Rows.Count
 .Range("a" & (rowt + 1)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True ' paste without blanks onto corresponding tab
 'Left(cRow(z), WorksheetFunction.Find(":", cRow(z)) - 1)
 End With
 cRow(z) = Empty
 Next z
Next key
'************
'Dictionary Lookup
'************
For b = 0 To dict.Count - 1
 Debug.Print dict.Keys(b), dict.Items(b)
Next b
Application.CutCopyMode = False
'clear memory
Set wb = Nothing
Set ws = Nothing
Set cell = Nothing
'Call next sub
Call SeparateTabsIntoWorkbooks
'call last sub
Call SaveFilestoDesktop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'clear dictionary
Set dict = Nothing
fin = Now
Debug.Print srt
Debug.Print fin
'Debug.Print DateDiff("s", CStr(fin), CStr(srt))
MsgBox "Started: " & srt & Chr(10) & "Completed: " & fin & Chr(10) & "Elapsed: " & Format(fin - srt, "h:mm:ss")
Exit Sub
'error handling
ext:
Application.DisplayAlerts = False
MsgBox err.Number & " " & err.Description, vbCritical + vbDefaultButton1, "Sheet name already exists!"
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub SeparateTabsIntoWorkbooks()
'*************************************************************************
'move all sheets based on selection into new workbooks with the name equal to the worksheet name
'*********************************************************************
Dim i As Long
Dim wb As Workbook
Dim wbn As String
Dim wk As Worksheet
Dim moved As Integer
Dim deleted As Integer
Set wb = ActiveWorkbook
wbn = wb.Name
 On Error GoTo erm
 For i = 2 To (wb.Sheets.Count - deleted)
 If Sheets(i - moved).Visible = xlSheetVisible Then
 With Worksheets(i - moved)
 .Columns.AutoFit
 .Rows.AutoFit
 .Move
 End With
 Application.CutCopyMode = False
 Else
 Sheets(i - moved).Delete
 deleted = deleted + 1
 End If
 Workbooks(wbn).Activate
 moved = moved + 1
 Next i
Exit Sub
erm:
MsgBox err.Number & Space(2) & err.Description
err.Clear
'MsgBox err.Number & Space(2) & err.Description
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub
Sub SaveFilestoDesktop()
'*************************************************************************
'save all open workbooks to desktop with date appending to it, and set up e-mail with subject to each user
'*********************************************************************
Dim wb As Workbook
Dim wks As String
Dim sjt As String
Dim fname As String
Retry:
sjt = InputBox("Subject of E-mail", "Notes.")
If sjt = vbNullString Then GoTo Retry
On Error GoTo errhandlr
 For Each wb In Workbooks
 wks = wb.ActiveSheet.Name
 If Left(wb.Name, 4) = "Book" Then
 fname = Application.DefaultFilePath & "\" & wb.Worksheets(1).Name & "- " & VBA.FormatDateTime(Date, vbLongDate) _
 & " (" & Format(Time, "hhmmss AMPM") & ")"
 With wb
 ' If Dir(fname) <> "" Then
 .SaveAs Filename:=fname, FileFormat:=51
 On Error Resume Next 'if tries to e-mail but it fails (such as for "blank")
 .SendMail Recipients:=Right(wks, Len(wks) - WorksheetFunction.Find(",", wks) - 1) & "_" & _
 Left(wks, WorksheetFunction.Find(",", wks) - 1) & "@quadra.ca", Subject:=sjt, ReturnReceipt:=True
 On Error GoTo 0
 .Close
 ' End If
 End With
 fname = Empty
 End If
 Next wb
Exit Sub
errhandlr:
MsgBox err.Number & Space(2) & err.Description
err.Clear
'MsgBox err.Number & Space(2) & err.Description
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub