creating unique new worksheets

  • Thread starter Thread starter stuph
  • Start date Start date
S

stuph

I have a large list of data from a database, and need to turn that into
worksheets in a larger VBA macro (as there are many other things that I
need to do with it in the future).

It consists of a person's name, and then many pieces of data
afterwards. The data also comes out by week, so names are often
repeated. something like this:


NAME Var1 Var2 Var3 etc week number

Person1 data data data 10
Person2 data data data 10
Person3 data data data 10
Person1 data data data 9
Person2 data data data 9
Person3 data data data 9
Person1 data data data 8
etc...

I would like to be able to make a new worksheet for each person in the
overall list, and copy all of their data over to their new worksheet,
in an arbitrary cell number.

Thanks in advance.
 
Sub test()
Const cPersonName = 1, cVar1 = 2, cVar2 = 3, cVar3 = 4, cWeek = 5
Dim wksS As Worksheet, wks As Worksheet, i As Long, j As Long,
lngLastRow As Long

Set wksS = Worksheets("Main Data")
lngLastRow = wksS.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lngLastRow
On Error Resume Next
Set wks = Worksheets(wksS.Cells(i, cPersonName).Value)
If Err.Number Then
Set wks = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wks.Name = wksS.Cells(i, cPersonName).Value
wks.Cells(1, cPersonName) = "Person Name"
wks.Cells(1, cVar1) = "Var1"
wks.Cells(1, cVar2) = "Var2"
wks.Cells(1, cVar3) = "Var3"
wks.Cells(1, cWeek) = "Week"
Err.Clear
End If
On Error GoTo 0

j = wks.Cells(Rows.Count, 1).End(xlUp).Row + 1
wks.Cells(j, cPersonName) = wksS.Cells(i, cPersonName)
wks.Cells(j, cVar1) = wksS.Cells(i, cVar1)
wks.Cells(j, cVar2) = wksS.Cells(i, cVar2)
wks.Cells(j, cVar3) = wksS.Cells(i, cVar2)
wks.Cells(j, cWeek) = wksS.Cells(i, cWeek)
Next
End Sub
 
Wow! Thanks for such a quick and useful response... after editing thi
a bit, it will do exactly what i need.. thanks again..
Sub test()
Const cPersonName = 1, cVar1 = 2, cVar2 = 3, cVar3 = 4, cWeek = 5
Dim wksS As Worksheet, wks As Worksheet, i As Long, j As Long,
lngLastRow As Long

Set wksS = Worksheets("Main Data")
lngLastRow = wksS.Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lngLastRow
On Error Resume Next
Set wks = Worksheets(wksS.Cells(i, cPersonName).Value)
If Err.Number Then
Set wks = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wks.Name = wksS.Cells(i, cPersonName).Value
wks.Cells(1, cPersonName) = "Person Name"
wks.Cells(1, cVar1) = "Var1"
wks.Cells(1, cVar2) = "Var2"
wks.Cells(1, cVar3) = "Var3"
wks.Cells(1, cWeek) = "Week"
Err.Clear
End If
On Error GoTo 0

j = wks.Cells(Rows.Count, 1).End(xlUp).Row + 1
wks.Cells(j, cPersonName) = wksS.Cells(i, cPersonName)
wks.Cells(j, cVar1) = wksS.Cells(i, cVar1)
wks.Cells(j, cVar2) = wksS.Cells(i, cVar2)
wks.Cells(j, cVar3) = wksS.Cells(i, cVar2)
wks.Cells(j, cWeek) = wksS.Cells(i, cWeek)
Next
End Sub
Click to expand...
 
Back
Top