How to create multiple worksheets from a list of cell values based on PO number

[hansgrandia]

[TABLE="class: grid, width: 100"]
<tbody>[TR]
[TD]Order

[/TD]
[TD]PO number
[/TD]
[TD]Art number
[/TD]
[TD]Amount
[/TD]
[/TR]
[TR]
[TD]123
[/TD]
[TD]1345
[/TD]
[TD]1
[/TD]
[TD]17
[/TD]
[/TR]
[TR]
[TD]123
[/TD]
[TD]1345
[/TD]
[TD]2
[/TD]
[TD]18
[/TD]
[/TR]
[TR]
[TD]123
[/TD]
[TD]1345
[/TD]
[TD]3
[/TD]
[TD]8
[/TD]
[/TR]
[TR]
[TD]456
[/TD]
[TD]6547
[/TD]
[TD]4
[/TD]
[TD]8
[/TD]
[/TR]
[TR]
[TD]456
[/TD]
[TD]6547
[/TD]
[TD]1
[/TD]
[TD]9
[/TD]
[/TR]
[TR]
[TD]789
[/TD]
[TD]4564
[/TD]
[TD]3
[/TD]
[TD]11
[/TD]
[/TR]
</tbody>[/TABLE]

Hello,

I have got a range of cells which I would like to split to multiple worksheet when a PO number changes (column B) to a new number. There is not a fixed number of rows per PO number (what makes it complicated). Also, I would like to take the same lay-out as the original/current sheet. How to approach?

Appreciated! Hans Grandia Netherlands

Sub PurchaseOrderSheet()

Application.ScreenUpdating = False

'Verwijderen van onnodige kolommen (sheet export)
With Sheets("exportdata")
        .Columns("D:P").EntireColumn.Delete
        .Columns("J:M").EntireColumn.Delete
        .Columns("L:AE").EntireColumn.Delete
End With

'De naam van enkele cellen aanpassen
Range("H1").Value = "Geleverd"
Range("I1").Value = "Verschil"
'In te vullen cellen leeg maken
Range("H2:I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Selection.End(xlUp).Select

'opmaak
ActiveSheet.PageSetup.Orientation = xlLandscape
Rows("1:1").Select
    Selection.Font.Bold = True
Range("A1").Select
ActiveCell.CurrentRegion.Select
    Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
End With

Rows("1:1").RowHeight = 30
Range("G1").Select
With Selection
    .WrapText = True
End With
Columns("A:K").Select
Columns("A:K").EntireColumn.AutoFit
Range("A1").Select

[code to create multiple sheets based on PO number]
End Sub

 

[Johnny Thunder]

If I am understanding correctly,

In column B, you want to have sheets added to your workbook if a new PO number is created? Do the PO Numbers you displayed on your data currently exist as tabs?

If you already have sheets for "1345", "6547", "4564" and someone adds a new number you can write a loop to see if the new number exists and if does not then create it. Is that what you wanted?

 

[hansgrandia]

Hello JT,
Thanks for reaching out. No, not when a PO is created. The table is a dump from a sql database and I'm seeking for a way that this single sheet can be devided in multiple sheets based on PO number. Every sheet/tab contains only data from a single PO number 1345 or 6547 etc. From VBA it's a single execution on a set of data (in real life there are app 60 POs on a sheet and I do not like to split them manullly. No one else can add PO numbers. It would be great if the name of the sheet is the PO number.
sql dump > Excel single sheet > Excel multiple sheets based on PO number (VBA)
Does this help? My English is probably not that great to express the need. It would be highly appreciated when you would help me out!
Regards,
Hans

 

[Johnny Thunder]

Here you go, let me know if this work for you.

From your example data, this code will use column B to identify all the unique PO Numbers and Create a sheet for the PO and then move all data from that PO to the same sheet name.

Option Explicit
Sub SecretSauce()
    Dim cell As Range, dataRng As Range
    Dim ShtNm As String


   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
    
    With Sheets("sheet1").UsedRange '<--| change "sheet1" with your actual sheet name
        Set dataRng = .Cells
        With .Offset(, .Columns.Count).Resize(, 1)
            .Value = .Parent.Columns("B").Value
            .RemoveDuplicates Columns:=Array(1), Header:=xlYes
            With .SpecialCells(XlCellType.xlCellTypeConstants)
                For Each cell In .Offset(1).Resize(.Rows.Count - 1)
                    AddSheet cell.Value
                    ShtNm = cell.Value
                    With dataRng
                        .AutoFilter field:=2, Criteria1:=cell.Value
                        .SpecialCells(xlCellTypeVisible).Copy
                        Sheets(ShtNm).Range("A1").PasteSpecial xlValues
                        Sheets(ShtNm).Columns("A:D").EntireColumn.AutoFit
                        Sheets(ShtNm).Range("A1").Select
                        Application.CutCopyMode = False
                    End With
                Next cell
            End With
            .Parent.AutoFilterMode = False
            .Clear
        End With
    End With
       
       
       With Sheets("Sheet1")
        .Activate
        .Range("E:E").Delete
        .Range("A1").Select
        End With
          
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
   
    MsgBox "Process Complete"
      
End Sub
Sub AddSheet(shtName As String)
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(shtName)
    On Error GoTo 0
    If ws Is Nothing Then Worksheets.Add.Name = shtName
End Sub

 

[hansgrandia]

Wow. Perfect. This works for me! Appreciated,
Hans