How to create multiple worksheets

[gmichaels]

I have a large spreadsheet w/ over 8000 lines. I want to create 15 different worksheets (1 for each supplier) is there a way to automatically do that? I have been copying and pasting. I thought there might be something in subtotal - like at every change in vendor, create new worksheet, but I can't find anything

 

[My Aswer Is This]

Surprise two of us have given you scripts but you only responded back to: Macropod

Did either of the scripts do what you wanted?

And I for one never open workbooks or links on this forum.
That is why I always want details in written words.
I do not respond when users say look here at my file or click this link for details.

 

[Fluff]

Surprise two of us have given you scripts but you only responded back to: Macropod

Did either of the scripts do what you wanted?

Not sure who you're talking to, but if it's @estevaoba he/she is not the OP

 

[Kenneth Hobson]

I am not sure that this meets post #1 request. This is a start to that end. After this, something similar can be done by a Sheet Change event which would just move that row to a new sheet or an existing sheet. I would prefer to run this manually but then I would just leave all the data and filter as needed.

In a Module, change the items in the INPUT block to suit. Always test on backup copy.

Sub Main()
  Dim calc As Integer, a, e, ms As Worksheet, ws As Worksheet
  Dim r As Range, c As Range, cn As Integer, rc As Range, rt As Range
  Dim d As Double
  d = Timer
'******************* INPUT ***********************************
  Set ms = Worksheets("Master")
  cn = 11 'Title columns to copy from row 1, 11=K.
'******************* END INPUT *******************************
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  On Error GoTo EndSub
  
  With ms
    Set rc = .Range("A1", .Cells(1, cn)) 'Title row
    Set r = .Range("B2", .Cells(Rows.Count, "B").End(xlUp))
    a = UniqueArrayByDict(r.Value)
    a = ArrayListSort(a)
    For Each e In a
      'Create worksheet if needed.
      If Not WorkSheetExists(CStr(e)) Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = e
        rc.Copy Worksheets(e).[a1]
      End If
      'Setup autofilter
      Set ws = Worksheets(e)
      .UsedRange.AutoFilter 2, e
      'Copy and paste found data.
      Set r = .Range("A2:A" & .Cells(.Rows.Count, "B").End(xlUp).Row).Resize(, cn).SpecialCells(xlCellTypeVisible)
      Set rt = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
      r.Copy
      rt.PasteSpecial xlPasteColumnWidths
      r.Copy rt
      r.Delete xlUp
    Next e
  End With
  
EndSub:
  On Error Resume Next
  ms.AutoFilterMode = False
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
  Debug.Print Timer - d
End Sub

 'WorkSheetExists in a workbook:
Function WorkSheetExists(sWorkSheet As String, Optional sWorkbook As String = "") As Boolean
    Dim ws As Worksheet, wb As Workbook
    On Error GoTo notExists
    If sWorkbook = "" Then
      Set wb = ActiveWorkbook
      Else
      Set wb = Workbooks(sWorkbook) 'sWorkbook must be open already.  e.g. ken.xlsm, not x:\ken.xlsm.
    End If
    Set ws = wb.Worksheets(sWorkSheet)
    WorkSheetExists = True
    Exit Function
notExists:
    WorkSheetExists = False
End Function

'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

Function ArrayListSort(a As Variant, Optional bAscending As Boolean = True)
  With CreateObject("System.Collections.ArrayList")
    Dim cl
    For Each cl In a
      .Add cl
    Next
     
    .Sort 'Sort ascendending
    If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
    ArrayListSort = .Toarray()
  End With
End Function

I like the idea of sub-arrays but the request was to create the sheets for the OP.

There are many good coders here which is one reason why I visit here once in a while. Maybe I will be banned someday because I prefer "short" files to best help a user. I waste a lot of time trying to work with add-ins and trying to understand what was posted by them. Some IT's don't allow add-ins which was a problem for me in the past.

 

[gmichaels]

You are a genius. Thank you so much, this has made my life a whole lot easier. Again, many, many thanks!

 

[My Aswer Is This]

Not sure which script you decided to use but glad we were able to help you

You are a genius. Thank you so much, this has made my life a whole lot easier. Again, many, many thanks!

 

[gmichaels]

I used the script you sent on 11/18 at 10:52 AM. I am a beginner level in excel, so this was most helpful. I will admit going to google to find out HOW to insert the macro (that is how inept I am at using excel) Again, your help is most appreciated.