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

 

[estevaoba]

Hi, gmichaels!

That's something doable. By using the formula below to exhibit current tab name, which corespond to one of your suppliers, I use that cell to anchor lookup formulas to split your master sheet into multiple ones.

[/COLOR][COLOR=#333333]MID(CELL("filename",A1),FIND("]",CELL("filename",A1))+1,255)[/COLOR][COLOR=#333333]

Maybe you find some free data transfer website, like wetransfer, and post a link here to download your mockup sheet.

 

[Macropod]

Maybe you find some free data transfer website, like wetransfer, and post a link here to download your mockup sheet.

Please don't encourage users to create external links to files; the 'Posting Aids' mentioned in the forum Guidelines (https://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html) are normally sufficient.

 

[My Aswer Is This]

I will be watching this thread closely. I'm interested as to how a formula can create new sheets and copy data to those sheets.

I would think you need to use Vba.

 

[Kenneth Hobson]

Welcome to the forum!

Did you want to copy the data or cut it to the other sheets? That is a fairly involved thing but a common sort of request. One can use auto or advanced filter for such. Once I get your answer, I can finish this autofilter method basic setup. I just need an answer to the question so I know to mark a column as copied if you want copy rather than cut unless this is a one time run deal.

The debug.print line is where I would add the check for sheet name, add the sheet if needed, add the title row, and then filter the data, and lastly, cut or copy filtered data. It is sleep time now or I would finish this out by making a guess for cut/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
  
'******************* INPUT ***********************************
  Set ms = Worksheets("Master")
  cn = 5 'Title columns to copy from row 1.
'******************* END INPUT *******************************
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    calc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  With ms
    Set rc = .Range("A1", .Cells(1, cn)) 'Title row
    Set r = .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
    a = ArrayListSort(r.Value)
    a = UniqueArrayByDict(a)
    For Each e In a
      Debug.Print e
    Next e
  End With
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = calc
    .CutCopyMode = False
  End With
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 guess one could use Excel4 macro to create new sheets but VBA would be my preference.

 

[My Aswer Is This]

I can write a script to do this but would need to know in what column are the sheet names.

I assume you want to look down column "A" for example and create a new sheet for every unique value. Then we copy each row of data to it's sheet.

So if "George" is in column "A" this row gets copied to sheet named "George" and so on.
We would need to know things like do you want the same header in each sheet.

But a previous poster here has said he can write a "Formula" to do this.

We always need exact details.

 

[gmichaels]

Cutting the data is fine. I would like to keep the same header on each page and the sheet names are in column B

 

[Fluff]

Hi & welcome to the board
Assuming the header is in row 1, try

Sub AddSht_FltrPaste()

    Dim Cl As Range
    Dim UsdRws As Long
    Dim OSht As Worksheet

Application.ScreenUpdating = False

    Set OSht = Sheets("Details")
    UsdRws = OSht.Range("B" & Rows.Count).End(xlUp).Row
    OSht.Range("A1").AutoFilter

    With CreateObject("scripting.dictionary")
        For Each Cl In Range("B2:B" & UsdRws)
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                OSht.Range("A1:G" & UsdRws).AutoFilter Field:=2, Criteria1:=Cl.Value
                If Not ShtExists(Cl.Value) Then
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = Cl.Value
                    OSht.Range("A1:A" & UsdRws).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
                        Sheets(Cl.Text).Range("A1")
                Else
                    MsgBox "Sheet " & Cl.Value & " already exists"
                End If
            End If
        Next Cl
    End With
    OSht.Range("A1").AutoFilter

End Sub

Public Function ShtExists(ByVal ShtName As String) As Boolean
    On Error Resume Next
    ShtExists = (LCase(Sheets(ShtName).Name) = LCase(ShtName))
    On Error GoTo 0
End Function

 

[My Aswer Is This]

Try this:
Run this script from the sheet with all your data.

Sub Filter()
'Modified 11-18-17 10:52 AM EST
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim c As Long
Dim ans As String
Dim Lastrow As Long
Dim Lastrowa As Long
Dim sn As String
sn = ActiveSheet.Name
Lastrow = Sheets(sn).Cells(Rows.Count, "B").End(xlUp).Row
Sheets.Add(After:=Sheets(sn)).Name = "Temp"
Sheets(sn).Range("B2:B" & Lastrow).Copy Sheets("Temp").Range("A1")
Lastrowa = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Temp").Range("A1:A" & Lastrowa).RemoveDuplicates 1, xlNo
Sheets(sn).Activate
Lastrowa = Sheets("Temp").Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrowa
        Sheets.Add(After:=Sheets("Temp")).Name = Sheets("Temp").Cells(i, 1).Value
    Next
 Sheets(sn).Activate
    For b = 2 To Lastrow
        ans = Cells(b, "B").Value
        Rows(b).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "B").End(xlUp).Row + 1)
    Next
    For c = 3 To Lastrowa + 2
     Sheets(sn).Rows(1).Copy Sheets(c).Rows(1)
    Next
MsgBox "I now need to delete a temp sheet I made. Just click Ok and then Delete"
Sheets("Temp").Delete
Application.ScreenUpdating = True
End Sub

 

[estevaoba]

Please don't encourage users to create external links to files; the 'Posting Aids' mentioned in the forum Guidelines (https://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html) are normally sufficient.

Hello, moderator Macropod. Sorry about that.

Trouble is that it’s a lot easier to make a point by using an actual excel file.
But anyway, here it goes.

I don’t know if user’s suppliers data are in columns so, assuming it is, first, in a new tab, I use formula below to label current tab name. In this case, I entered it in AE1, so it is not easily visible and will not disturb any other data.

=RIGHT(CELL("filename",AF1), LEN(CELL("filename", AF1))- SEARCH("]",CELL("filename",AF1)))

Next, I arrow enter formula below in new tab B2 and copy across and down.

=IFERROR(INDEX(LEV.CARGAS!$B$2:$AA$119,SMALL(IF(LEV.CARGAS!$N$2:$N$119='QD-EST'!$AE$1,ROW(LEV.CARGAS!$N$2:$N$119)-1),ROW($A1)),COLUMN(A$1)),"")
(Adapt sheet names and ranges to suit)

Then I rename new tab as the first unique item in column N and all correspondent rows are listed in new tab.

Make copies of new tab and rename them as the other unique items in column N.