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

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