VBA Create Array For New Worksheets

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I'm using the code below to search column B on the "All Data" sheet, and where a unique value is found create a new sheet and use the value from column B as the sheet name.

Sub AddSheets()

    Application.ScreenUpdating = False
    
    Dim bottomA As Integer
    Dim i As Long 'counter variable
    Dim rng As Range
    Dim shArray() As Variant 'Declare the sheet Name array
    Dim ws As Worksheet
    
    Set ws = Sheets("All Data")
    
    ws.Select
    
    bottomB = Range("B" & Rows.Count).End(xlUp).Row

    For Each rng In Range("B8:B" & bottomB)
        If rng <> rng.Offset(1, 0) Then
            Set ws = Nothing
            On Error Resume Next
            Set ws = Worksheets(rng.Value)
            On Error GoTo 0
            If ws Is Nothing Then
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = rng.Value
            End If
        End If
    Next rng
End Sub

The question I have is could someone perhaps tell me please how I can assign a variable to create an array when the new sheets are created.

I'm assuming that the change is needed here, Worksheets.Add(After:=Sheets(Sheets.Count)).Name = rng.Value but I may very well be wrong.

Many thanks and kind regards

Chris

[patel45]

attach please a sample file for testing

[hobbiton73]

Hi @patel45, thank you for taking the time to reply to my post.

Unfortunately the file is large in size, so I was trying, if possible not to this, if that's feasible. I'm just really looking for some guidance which I can then take forward?

Many thanks and kind regards

Chris

[AB33]

Do you want this one?

Option Explicit

Sub AddSheets()

    Application.ScreenUpdating = False
    
    Dim bottomA As Integer, bottomB As Long
    Dim i As Long 'counter variable
    Dim rng As Range
    Dim shArray() As Variant 'Declare the sheet Name array
    Dim ws As Worksheet
    
      Set dic = CreateObject("scripting.dictionary")
      dic.CompareMode = 1
    Set ws = Sheets("All Data")
    
    bottomB = Range("B" & Rows.Count).End(xlUp).Row

    For Each rng In Range("B8:B" & bottomB)
        If rng <> rng.Offset(1, 0) Then
             If Not Evaluate("ISREF('" & rng & "'!A1)") Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = rng
             End If
        End If
    Next rng
End Sub

[AB33]

Another one using your favourite topic

Sub AddSheetsmine()

    Application.ScreenUpdating = False
    
    Dim dic As Object, bottomB As Long
    Dim rng As Range
    Dim ws As Worksheet
    
      Set dic = CreateObject("scripting.dictionary")
      dic.CompareMode = 1
    Set ws = Sheets("All Data")
    
    bottomB = ws.Range("B" & Rows.Count).End(xlUp).Row

    For Each rng In ws.Range("B8:B" & bottomB)
         If Not dic.exists(rng) Then dic.Item(rng) = Empty
             If Not Evaluate("ISREF('" & rng & "'!A1)") Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = rng
             End If
    Next rng
End Sub

[hobbiton73]

Hi @AB33, thank you very much for coming back to me with this.

Forgive me, but could you tell me please where you create the array. I see the Array set as the variable but not in the rest of the script?

Perhaps it's my lack of knowledge.

Many thanks and kind regards

Chris

[AB33]

Chris,
The code could lead to lots of errors and wrong outcome. There was not need to create sheet arrays, hence that variable was not used on the code. If you look at my second code , I have amended few lines on the code. If the aim of the code was to create unique names, my second code works well.

[jolivanes]

Or with advanced filter

Sub Try()
    Dim lr As Long, c As Range
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    Range("B1").AutoFilter
    Range("B1:B" & lr).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    For Each c In Range("B2:B" & lr).SpecialCells(12)
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
    Next c
    Sheets("All Data").ShowAllData
End Sub

[jolivanes]

Or if you insist on an Array
This assumes a header in B1

Sub If_You_Insist_On_Array()
    Dim c As Range, rng As Range, i As Long, j As Long
    Dim myArray() As String
    Application.ScreenUpdating = False
    Set rng = Range("B3", Range("B" & Rows.Count).End(xlUp))
    ReDim myArray(1 To 1)
    myArray(1) = [B2]
    i = 2
    For Each c In rng
        If Application.WorksheetFunction.CountIf(Range("B2:" & c.Address), [c]) = 1 Then
            ReDim Preserve myArray(1 To i)
            myArray(i) = [c]
            i = i + 1
        End If
    Next c
    For j = LBound(myArray) To UBound(myArray)
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = myArray(j)
    Next j
    Application.ScreenUpdating = True
End Sub

[hobbiton73]

Hi @jolivanes, thank you very much for taking the time to reply to my post and for the solutions you've put together as an alternative method to that shown by @AB33.

All the best and kind regards

Chris

[hobbiton73]

Hi @AB33, thank you very much for coming back to me with this with the explanation and amended code which works great.

All the best and kind regards

Chris