Need a VB code to generate sheets from a list of cells

This should work for the most part. Paste it into a workbook, save, and reopen. Then type anywhere in column A in worksheet 1. Note: Column B will need to be used as well. This code needs to keep track of the name the last time it did an update, so that when you delete a file it knows what file to delete and also if you make a name change.

Sub auto_open()

   ' Run the macro DidCellsChange any time a entry is made in a
   ' cell in Sheet1.
   ThisWorkbook.Worksheets("Sheet1").OnEntry = "DidCellsChange"

End Sub


Sub DidCellsChange()
  Dim KeyCells As String
   ' Define which cells should trigger the KeyCellsChanged macro.
   KeyCells = "A1:A100"

   ' If the Activecell is one of the key cells, call the
   ' KeyCellsChanged macro.
   If Not Application.Intersect(ActiveCell, Range(KeyCells)) _
   Is Nothing Then copysht

End Sub


Sub copysht()
    Dim cl     As Range
    Col = 1
    Row = 1
    EmptySheets = 0
    Do
        If IsEmpty(Sheet1.Cells(Row, Col).Value) Then
            If IsEmpty(Sheet1.Cells(Row, Col + 1).Value) Then
            Else
                Application.DisplayAlerts = False
                Worksheets(Sheet1.Cells(Row, Col + 1).Value).Delete
                Application.DisplayAlerts = True
                Sheet1.Cells(Row, Col + 1).ClearContents
            End If
            EmptySheets = EmptySheets + 1
        ElseIf IsEmpty(Sheet1.Cells(Row, Col + 1)) Then
            Sheet2.Copy after:=Sheets(Row + 1 - EmptySheets)
            ActiveSheet.Name = Sheet1.Cells(Row, Col).Value
            Sheet1.Cells(Row, Col + 1) = Sheet1.Cells(Row, Col)
        Else
            If Sheet1.Cells(Row, Col + 1).Value = Sheet1.Cells(Row, Col).Value Then
                'Nothing Changed
            Else
                Worksheets(Sheet1.Cells(Row, Col + 1).Value).Select
                ActiveSheet.Name = Sheet1.Cells(Row, Col).Value
                Sheet1.Cells(Row, Col + 1) = Sheet1.Cells(Row, Col)
            End If
        End If
        Row = Row + 1
    Loop Until Row >= 50
    Sheet1.Select
End Sub

Heading off home in 5 mins, so will try these out tomorrow - thanks guys, looks like you may have cracked in 20 minutes what took me all day! rofl


Think i am gonna like this forum!

Have sorted two aspects of above problems....

If it format the cells containing numbers as text it reads them, so thats no issues now.

And to ensure it wont delete the worksheets i dont want touching i can simply add them to the list in column A and hide the rows. So thats sorted too...

All that remains is for it to copy an existing sheet rather than create a new one.

Is it possible to add the new sheets before a sheet called "end" rather than automatticaly placing them as the last sheet in the workbook?


Thanks in advance for any ideas!

Originally Posted by Thanatos

Is it possible to add the new sheets before a sheet called "end" rather than automatticaly placing them as the last sheet in the workbook?

Thanks in advance for any ideas!

Fixed above with this replacing 7th line of code

ActiveSheet.Move Before:=Sheets(“end”)

All that remains is for it to copy an existing sheet rather than create a new one

Anyone up for the challenge? :D

Current code read:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error Resume Next
a = Sheets("adduser").Range("A65536").End(xlUp).Row
For n = 1 To a
If SheetExists(Sheets("adduser").Cells(n, 1).Value) = False Then
Sheets.Add.Name = Sheets("adduser").Cells(n, 1).Value
ActiveSheet.Move Before:=Sheets("end")
End If
Next n
For Each WkSht In ActiveWorkbook.Worksheets
chk = 0
For n = 1 To a
If WkSht.Name = Sheets("adduser").Cells(n, 1).Value Then chk = 1
Next n
If chk = 0 And Not WkSht.Name = "adduser" Then
Sheets(WkSht.Name).Delete
End If
Next WkSht
Sheets("adduser").Activate
End Sub

Private Function SheetExists(Sht) As Boolean
On Error Resume Next
Set x = ActiveWorkbook.Sheets(Sht)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function

Managed to do it by combining the two codes you guys supplied. Doubt it will help anyone here, but this is the final code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

ActiveWorkbook.Unprotect "letmein"
On Error Resume Next
a = Sheets("adduser").Range("A65536").End(xlUp).Row
For n = 1 To a
If SheetExists(Sheets("adduser").Cells(n, 1).Value) = False Then
Sheet3.Copy Before:=Sheets("end")
ActiveSheet.Name = Sheets("adduser").Cells(n, 1).Value
End If
Next n
For Each WkSht In ActiveWorkbook.Worksheets
chk = 0
For n = 1 To a
If WkSht.Name = Sheets("adduser").Cells(n, 1).Value Then chk = 1
Next n
If chk = 0 And Not WkSht.Name = "adduser" Then
Sheets(WkSht.Name).Delete
End If
Next WkSht
Sheets("adduser").Activate
End Sub

Private Function SheetExists(Sht) As Boolean
On Error Resume Next
Set x = ActiveWorkbook.Sheets(Sht)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function

Thanks for all your help!