Auto fill Sheets

[Diogo]

Hello everyone.
I've one doubt that I was hopping someone could help me with.

I used this function to automate creation of 200 sheets in my workbook:

#
Sub New_Sheets()
Dim intNumber As Integer, Counter As Integer
intNumber = _
Application.InputBox("Create how many sheets?", "Number of new sheets", "300")

Application.ScreenUpdating = False
For Counter = 1 To intNumber
Worksheets.Add
Next
Application.ScreenUpdating = True
End Sub
#

I then have one sheet (sheet1) that looks something like this:
A B
1 Name: ID:
2 Mike 123
3 Sam 456
4 Carol 789
5 John 945


I recorded a macro that does the following:

#
Sub Macro1()
'
' Macro1 Macro
'

'
Selection.Copy
Sheets("Sheet2").Select
Range("B1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("B2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("B2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("A3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("B1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("B3").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("B2").Select
ActiveSheet.Paste
End Sub
#

OK how do I automate this process so it creates a individualized sheet for
each worker? Thanks in advanced

 

[Barb Reinhardt]

Try something like this. Modify as needed

Sub CreateNewSheet()
Dim lRow As Long
Dim aWS As Worksheet
Dim myWS As Worksheet
Dim aWB As Workbook
Dim myRange As Range

Set aWB = ActiveWorkbook
Set aWS = ActiveSheet
lRow = aWS.Cells(aWS.Rows.Count, 1).End(xlUp).Row 'determines the last row
for column 1
If lRow = 1 Then
MsgBox ("You don't have any data in column 1 of the active sheet.")
End If

Set myRange = aWS.Cells(2, 1).Resize(lRow - 2 + 1, 1)
Debug.Print myRange.Address
For Each r In myRange
If Not IsEmpty(r) Then
'Creates new worksheet and adds at the end
aWB.Worksheets.Add after:=aWB.Worksheets(aWB.Worksheets.Count)
Set myWS = ActiveSheet
'Puts the value of ID in B1 on each sheet
myWS.Range("B1").Value = r.Offset(0, 1).Value

'Defines the worksheet name to be equal to the ID
On Error Resume Next
myWS.Name = r.Offset(0, 1).Value
On Error GoTo 0
End If
Next r

End Sub