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