View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
Dick Kusleika Dick Kusleika is offline
external usenet poster
 
Posts: 179
Default How? Macro to copy range to new worksheet, name new worksheet, loop

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
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

"Repoman" wrote in message
om...
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