How? Macro to copy range to new worksheet, name new worksheet, loop

[Repoman]

Hello Excel Experts,

I'm looking for a macro that can copy range A2:G2 in the worksheet
"setup" to a new worksheet, name the new worksheet according to the
value in cell A2, and then repeat the procedure for the next row
(A3:G3). The macro should continue to run until all rows with data in
"setup" have been copied to new sheets. "Nice to have" but not
necessary would be a step to copy the header row of "setup" A1:G1 to
each of the new sheets at the top.

I found macros in this group to copy the range and create a worksheet,
and a looping macro to create new worksheets based on a list, but I
can't figure out how to combine the two. I've posted them below. (is
it proper netiquette to name the people who posted them originally?)

Any help would be greatly appreciated. Thanks, E. Kohl


Sub CopyRange()
Dim ws As Worksheet, ws1 As Worksheet, c As Range
Set ws = ActiveSheet
Set c = ActiveCell
Set ws1 = Sheets.Add
ws.Range("A2:G2").Copy ws1.Range("A1")
ws1.Name = ws1.Range("A1")
ws.Select
c.Select
End Sub

Sub nameSheetsFromSheet()
Dim vNames() As Variant
Dim Cntr As Long
Dim wbNew As Worksheet
vNames() = Worksheets("Setup").Range("A2:A" & Worksheets("Setup") _
.Range("B65536").End(xlUp).Row).Value
For Cntr = 1 To UBound(vNames())
Set wbNew = ThisWorkbook.Worksheets.Add
wbNew.Name = vNames(Cntr, 1)
Set wbNew = Nothing
Next Cntr
End Sub

 

[Swenk]

Why dont you name your worksheet sonce your loop is completed. use
this bit of code. Must change cell references.

Dim n As Integer
Dim wa As Worksheet
For Each wa In ActiveWorkbook.Worksheets
wa.Activate
On Error Resume Next
wa.Name = Range("a2").Value
Next

 

[Dick Kusleika]

E

Try this macro

Sub MakeSheets()

Dim cell As Range
Dim Rng As Range
Dim wsh As Worksheet

Set Rng = Sheet1.Range("a2", Sheet1.Range("A2").End(xlDown))

'Loop through cells
For Each cell In Rng.Cells

'Create new sheet
Set wsh = ThisWorkbook.Worksheets.Add(, _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

'Copy header row
cell.Offset(-cell.Row + 1, 0).Resize(, 7).Copy _
wsh.Range("a1")

'Copy data row
cell.Resize(, 7).Copy _
wsh.Range("A65536").End(xlUp).Offset(1, 0)
Next cell


End Sub

 

[Dick Kusleika]

E

I forgot to rename the sheet. See code below for change

Sub MakeSheets()

Dim cell As Range
Dim Rng As Range
Dim wsh As Worksheet

Set Rng = Sheet1.Range("a2", Sheet1.Range("A2").End(xlDown))

'Loop through cells
For Each cell In Rng.Cells

'Create new sheet
Set wsh = ThisWorkbook.Worksheets.Add(, _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

'Copy header row
cell.Offset(-cell.Row + 1, 0).Resize(, 7).Copy _
wsh.Range("a1")

'Copy data row
cell.Resize(, 7).Copy _
wsh.Range("A65536").End(xlUp).Offset(1, 0)

On Error Resume Next
wsh.Name = wsh.Range("A2").Value
On Error Goto 0

 

[E. Kohl]

Hi Swenk,

Thanks for the quick reply. I follow what you're saying and I will use
your code to name the worksheets; however, I still don't know how to
integrate the looping code of the second macro into the copy code of the
first macro. Perhaps I didn't explain it well enough:

The first macro copies a range to a new worksheet and names the
worksheet according to the value in A1. It does not loop at all:

Sub CopyRange()
Dim ws As Worksheet, ws1 As Worksheet, c As Range
Set ws = ActiveSheet
Set c = ActiveCell
Set ws1 = Sheets.Add
ws.Range("A2:G2").Copy ws1.Range("A1")
ws1.Name = ws1.Range("A1")
ws.Select
c.Select
End Sub

This macro "loops" by going through a list and creating new sheets until
the list is finished (please note that the two macros are from different
sources and thus have different "dim" definitions:

Sub nameSheetsFromSheet()
Dim vNames() As Variant
Dim Cntr As Long
Dim wbNew As Worksheet
vNames() = Worksheets("Setup").Range("A2:A" & Worksheets("Setup") _
Range("B65536").End(xlUp).Row).Value
For Cntr = 1 To UBound(vNames())
Set wbNew = ThisWorkbook.Worksheets.Add
wbNew.Name = vNames(Cntr, 1)
Set wbNew = Nothing
Next Cntr
End Sub

What I need is a macro that copies a range to a new worksheet AND
repeats this step until all of the elements in the list have been copied
to new worksheets.

I can follow the logic of the first macro and the macro that you sent,
but I have no clue on the looping code in the second macro. Could you
help me to combine them? Thanks a lot! E. Kohl



*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[E. Kohl]

Dick,

Thanks for the quick reply! I'll give it a wirl and let you know.

Regards,

Edward



*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[E. Kohl]

Hello Dick,

Sorry if I'm being an idiot, but when I run the macro that you posted,
Excel simply starts an endless loop of creating new worksheets. It gets
to about 850 sheets and then I get the Run time error 1004 "Method 'Add'
of Object 'Sheets' failed." The debugger points me to this line:

'Create new sheet
Set wsh = ThisWorkbook.Worksheets.Add(, _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

Any ideas? Thanks in advance. Edward




*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[Dick Kusleika]

Edward

That's my fault. This line

Set Rng = Sheet1.Range("a2", Sheet1.Range("A2").End(xlDown))

needs to be changed to this

If Sheet1.Range("A65536").End(xlUp).Address = $A$1 Then
Set Rng = Sheet1.Range("a2")
Else
Set Rng = Sheet1.Range("a2", Sheet1.Range("A65536").End(xlUp))
End If

I think the problem is that you only have a value in A2 and nothing below
it. (Alternatively, you could have values in every cell in column A, but
it's not likely.) The loop creates a sheet for every value in column A,
except A1. The Range("A2").End(xlDown) statement is like selecting A2 and
hitting the End key, then the Down Arrow. If that takes you to the bottom
of the sheet (row 65536), then the loop will try to create 65,536 new
sheets. You don't have enough memory for that - no one does.

So changed it to start at the bottom and go up. This will ensure that if
there is only a value in A2 and no other values below it, then only one new
sheet will be created.

That was just a little sloppiness on my part. Try the new way and let me
know if it works.

 

[E. Kohl]

Dick,

I replaced the line with the new code but I now get a "Compile Error:
Syntax error" and the debugger highlights the first line of the new
lines:

If Sheet1.Range("A65536").End(xlUp).Address = $A$1 Then

Also, when I copied and pasted the new lines into the module window, the
font color of the first line automatically changed to red.

Regarding your other points, the worksheet contains data from A2 to G17
with the header in A1 to G1.

Thanks a lot for the explanation on Range("A2").End(xlDown), etc. I'm
slowly starting to get a feel for what the code means. Thanks again,
Edward



*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[Dick Kusleika]

Edward

Make sure you change the sheet references to match your situation. I don't
know how your sheets are named, but if the sheet with the data is named
DATA, then that line will read

If Sheets("DATA").Range("A65536").End(xlUp).Address = $A$1 Then