Cfrtjryk

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

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