Excel problem create sheets

[KlausW]

I use this VBA code to create sheets based on what is written in column A, starting in A3. What I would like Excel to do is just create folders based on whether there is something in cells A3 and below. As you can see in the example, there are numbers from 1 to 6 but it can easily be 1 to 10 or higher.
All help will be appreciated, regards Klaus W

Option Explicit

Dim wb As Workbook

Dim ws As Worksheet, wsStamdata As Worksheet, wsCopy As Worksheet

Dim Area As Range, Arr() As Variant

Dim Count As Integer

Sub CopyArk()

With Application

.ScreenUpdating = False

.DisplayAlerts = False

End With

Set wb = ThisWorkbook

Set wsCopy = Sheets("Master") ' Navnet på kopisiden

Set wsStamdata = Sheets("Stamdata")

Set Area = wsStamdata.Range("A3")

Set Area = Range(Area, Area.End(xlDown))

Arr = Area

For Count = LBound(Arr, 1) To UBound(Arr, 1)

For Each ws In wb.Sheets

If ws.Name = Arr(Count, 1) Then ws.Delete

Next

Next

For Count = LBound(Arr, 1) To UBound(Arr, 1)

wsCopy.Copy After:=Sheets(Sheets.Count)

Set ws = ActiveSheet

With ws

.Name = Arr(Count, 1)

.Range("A1").Formula = "='Stamdata'!A" & Count + 2

End With

Next

With Application

.ScreenUpdating = True

.DisplayAlerts = True

End With

End Sub

 

[KlausW]

Thanks

 

[GWteB]

Are you looking for something like this?

Option Explicit

Dim wb As Workbook
Dim ws As Worksheet, wsStamdata As Worksheet, wsCopy As Worksheet
Dim Area As Range, Arr() As Variant
Dim Count As Integer


Sub CopyArk_r2()
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set wb = ThisWorkbook
    Set wsCopy = Sheets("Master") ' Navnet på kopisiden
    Set wsStamdata = Sheets("Stamdata")
    Set Area = wsStamdata.Range("A3")
    Set Area = Range(Area, Area.End(xlDown))
    
    Arr = Area
    
    For Count = LBound(Arr, 1) To UBound(Arr, 1)
        For Each ws In wb.Sheets
            If ws.Name = Arr(Count, 1) Then ws.Delete
        Next
    Next
    
    ' _______ create folders based on values in column A _____
    
    Const cHostFolder   As String = "C:\Users\KlausW\Documents\SomeFolder"  ' <<  Change as required
    
    Dim oFSO As Object, oFolder As Object

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set oFolder = oFSO.getfolder(cHostFolder)
    On Error GoTo 0
    If Not oFolder Is Nothing Then
        For Count = LBound(Arr, 1) To UBound(Arr, 1)
            On Error Resume Next
            oFSO.CreateFolder oFolder.Path & "\" & Arr(Count, 1)
            If Err.Number <> 0 Then
                MsgBox "Couldn't create folder " & oFolder.Path & "\" & Arr(Count, 1)
                Err.Clear
            End If
            On Error GoTo 0
        Next
    Else
        MsgBox "Folder " & cHostFolder & " does not exist"
    End If
    ' __________________________________________________________
    
    
    For Count = LBound(Arr, 1) To UBound(Arr, 1)
        wsCopy.Copy After:=Sheets(Sheets.Count)
        Set ws = ActiveSheet
        With ws
            .Name = Arr(Count, 1)
            .Range("A1").Formula = "='Stamdata'!A" & Count + 2
        End With
    Next
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[KlausW]

No, that's not what I want at all. It is to create sheets based on the value in column A. There can be numbers 1 to 4 then EXCEL must make 4 sheets, it can be numbers 1 to 12 EXCEL must make 12 sheets, it can vary from time to time and they must be in same file. EXCEL should not make them in another folder. See picture.

 

[GWteB]

What I would like Excel to do is just create folders based on whether there is something in cells A3 and below.

Right, misunderstood ... let me look into it ...

 

[GWteB]

Replace my previous addition to your existing code with the code below and see if this is what you're after ...

    ' ________ create worksheets based on values in column A ______
    
    Dim oWsA As Worksheet, oWsNew As Worksheet
    Set oWsA = wsCopy
    For Count = LBound(Arr, 1) To UBound(Arr, 1)
        Set oWsNew = ThisWorkbook.Sheets.Add(After:=oWsA)
        oWsNew.Name = Arr(Count, 1)
        Set oWsA = oWsNew
    Next
    ' _______________________________________________________________

 

[KlausW]

I got an error in line .Name = Arr(Count, 1)
And it makes a sheet name Master2 with EXCEL not shall do see image.

 

[GWteB]

This worksheet name indicates that an existing worksheet has been copied.
Some of your original code turns out to do that.
I have adjusted the overall procedure as I think you had it in mind.
Note that I declared the variables with local scope (ie within the procedure), so they have to be removed from module level.

Sub CopyArk_r3()

    Dim wb As Workbook
    Dim ws As Worksheet, wsStamdata As Worksheet, wsCopy As Worksheet
    Dim Area As Range, Arr() As Variant
    Dim Count As Integer
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set wb = ThisWorkbook
    Set wsCopy = Sheets("Master") ' Navnet på kopisiden
    Set wsStamdata = Sheets("Stamdata")
    Set Area = wsStamdata.Range("A3")
    Set Area = Range(Area, Area.End(xlDown))
    
    Arr = Area
    
    For Count = LBound(Arr, 1) To UBound(Arr, 1)
        For Each ws In wb.Sheets
            If ws.Name = Arr(Count, 1) Then ws.Delete
        Next
    Next
    ' ________ create worksheets based on values in column A ______

    Dim oWsA As Worksheet, oWsNew As Worksheet
    Set oWsA = wsCopy
    For Count = LBound(Arr, 1) To UBound(Arr, 1)
        Set oWsNew = ThisWorkbook.Sheets.Add(after:=oWsA)
        oWsNew.Name = Arr(Count, 1)
        oWsNew.Range("A1").Formula = "='Stamdata'!A" & Count + 2   ' <<<<< from your original code
        Set oWsA = oWsNew
    Next
    ' ______________________________________________________________
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[KlausW]

Thanks I'll will look at it tomorrow

 

[GWteB]

You are welcome and any feedback is appreciated.