Code for creating new worksheets

[Daboyz1971]

Good morning:

New to VBA code to have the below data created in new worksheet. The new worksheet should be named from ColA and contain chair, table and rug. Another worksheet should be named stock and contain desk, computer, lamp and paper.


Col A ColB
inventory chair
inventory table
inventory rug
stock desk
stock computer
stock lamp
stock paper

 

[Andrew Poulsom]

Try:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim r As Long
    Set Sh = Worksheets("Sheet1")
    With Sh
        Set Rng = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
        For Each Cell In Rng
            If Cell.Value <> Cell.Offset(-1).Value Then
                r = 1
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cell.Value
            Else
                r = r + 1
            End If
            ActiveSheet.Range("A" & r).Value = Cell.Offset(, 1).Value
        Next Cell
    End With
End Sub

The code assumes your data starts in row 2 of column A.

 

[Trevor G]

If you want to use code you would use

Sub create1()
Sheets.Add
ActiveSheet.Name = Worksheets("Sheet1").Range("A2")
Range("A1") = "Chair"
Range("A2") = "Table"
Range("A3") = "Rug"
Sheets.Add
ActiveSheet.Name = Worksheets("Sheet1").Range("A4")
Range("A1") = "Desk"
Range("A2") = "Computer"
Range("A3") = "Lamp"
Range("A4") = "Paper"

End Sub

But if you want to split the data from one sheet to individuals there is more to this, if so then let me know and I will add some code to do that.

 

[Ruddles]

Try this in a copy of your workbook:-

[FONT=Courier New]Option Explicit[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]Public Sub SplitSheet()
  
  Dim iLastRow As Long
  Dim iRow As Long
  Dim mws As Worksheet
  Dim nws As Worksheet
  Dim nwsName As String
  Dim nwsRow As Long
  
  Set mws = ThisWorkbook.Sheets("[COLOR=red][B]Sheet1[/B][/COLOR]")
  
  For Each nws In ThisWorkbook.Worksheets
    If nws.Name <> mws.Name Then
      Application.DisplayAlerts = False
      On Error Resume Next
      nws.Delete
      On Error GoTo 0
      Application.DisplayAlerts = True
    End If
  Next nws[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]  iLastRow = mws.Cells(mws.Rows.Count, "A").End(xlUp).Row
    
  For iRow = 2 To iLastRow
    nwsName = mws.Cells(iRow, "A").Value
    Set nws = Nothing
    On Error Resume Next
    Set nws = Sheets(nwsName)
    On Error GoTo 0
    If nws Is Nothing Then
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = nwsName
      Set nws = Sheets(nwsName)
      mws.Range("B1").Copy Destination:=nws.Range("A1")
    End If
    nwsRow = nws.Cells(nws.Rows.Count, "A").End(xlUp).Row + 1
    nws.Cells(nwsRow, "A") = mws.Cells(iRow, "B").Value
  Next iRow
  
  mws.Activate
    
  MsgBox "Done: " & CStr(iLastRow - 1) & " items copied, " _
       & CStr(Sheets.Count - 1) & " new sheets created." & Space(10), _
       vbOKOnly + vbInformation[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]End Sub[/FONT]

It's expecting your main sheet to be called Sheet1: change the code in red if it isn't. All other sheets will be deleted when the code runs. It's also expecting column headings in row 1: best not to disappoint it.

 

[MickG]

Just another option.

[COLOR="Navy"]Sub[/COLOR] MG02Mar39
Private [COLOR="Navy"]Sub[/COLOR] CommandButton1_Click()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] sht [COLOR="Navy"]As[/COLOR] Worksheet
[COLOR="Navy"]Dim[/COLOR] nSht [COLOR="Navy"]As[/COLOR] Worksheet
[COLOR="Navy"]Set[/COLOR] sht = ActiveSheet
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
                [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.value) [COLOR="Navy"]Then[/COLOR]
                    .Add Dn.value, Dn(, 2).Address & ":" & Dn(, 2).Address
                [COLOR="Navy"]Else[/COLOR]
                    .Item(Dn.value) = Split(.Item(Dn.value), ":")(0) & ":" & Dn(, 2).Address
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]Set[/COLOR] Rng = sht.Range(.Item(K))
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = K
            [COLOR="Navy"]Set[/COLOR] nSht = ActiveSheet
                nSht.Range("A1").Resize(Rng.Count) = Rng.value
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Daboyz1971]

Thanks for all the replies. Ruddles code was just what I needed.

Thanks again.