Solved excel - create worksheets from a master based on a row

August 21, 2013 at 10:23:29
Specs: Windows XP
I would like to beg for some help. I have a worksheet with 13 columns of infomation. The number of rows can be as high as 400, but information start on row 2 with row one being the column header I have a macro I found on this site that will create the worksheet but I cannot find something that will put the header Row 1 on each new sheet. Below in the macro I am using to create the sheets. Thanks in advance

Private Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names/numbers for worksheets)
Set rngStart = Worksheets("Sheet2").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet2"). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with sheet names/numbers
For Each rngCell In Range(rngStart, rngEnd)
'get name/number
strWsName = rngCell.Text
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy 5 cells to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)). _
End(xlUp).Offset(1, 0)
rngCell.Resize(1, 13).Copy
rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
End Sub

message edited by garmelvin


See More: excel - create worksheets from a master based on a row

Report •


#1
August 22, 2013 at 08:23:01
Are you just trying to create a new worksheet with the same header row and that's it? Or are you trying to copy some of the data over in addition to wanting the header row?

Your code is also naming the new worksheet using the contents of the first cell in the row it copies. Is that something you want it to do too?

If you give us a little more information on what you're trying to accomplish, we could clean up your code and make it do what you want!

Law of Logical Argument: Anything is possible if you don't know what you're talking about.


Report •

#2
August 22, 2013 at 09:08:41
Thank for the reply Newbie 10. The code I am using does create a new sheet and names it with the information in Column A and copies over the information from that row into row 2 of each new sheet, which is what I want at this point, However if does not copy the hearder row (row 1) and place it on each sheet. Any clean up of the code would be nice also. THANKS

Report •

#3
August 22, 2013 at 10:22:18
✔ Best Answer
Well, you never really answered any of my questions, but try this:

Sub CommandButton1_Click()
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestEnd As Range
Dim strWsName As String
Dim rngNewHeader As Range

On Error GoTo ErrHnd

'turn off screen updating to stop flicker
Application.ScreenUpdating = False

'set start of data (range containing names/numbers for worksheets)
Set rngStart = Worksheets("Sheet2").Range("A2")

'set end of range
Set rngEnd = Worksheets("Sheet2"). _
Range("A" & CStr(Application.Rows.Count)).End(xlUp)

'Loop through all cells with sheet names/numbers
For Each rngCell In Range(rngStart, rngEnd)
'get name/number
strWsName = rngCell.Text
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist, so create & name it
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
End If
'if name was valid for a worksheet, copy 5 cells to that named sheet
'find empty row after end of destination data
Set rngDestEnd = Worksheets(strWsName). _
Range("A" & CStr(Application.Rows.Count)). _
End(xlUp).Offset(1, 0)
rngCell.Resize(1, 13).Copy
rngDestEnd.PasteSpecial (xlPasteValuesAndNumberFormats)
Set rngNewHeader = Worksheets(strWsName).Range("A1:M1")
Worksheets("Sheet2").Range("A1:M1").Copy
rngNewHeader.PasteSpecial (xlPasteValues)
Next rngCell
'restore screen updating
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
'restore screen updating
Application.ScreenUpdating = True
End Sub

Law of Logical Argument: Anything is possible if you don't know what you're talking about.


Report •

Related Solutions

#4
August 22, 2013 at 10:25:05
I didn't catch it before I posted, but you will need to change my code from a sub to a private sub. I changed it so I could just run it as a regular macro for testing purposes...

Law of Logical Argument: Anything is possible if you don't know what you're talking about.


Report •

#5
August 22, 2013 at 10:36:45
Newie. I am turely sorry I did not answer your questions and will try better next time. I am at a Dr appointment right now and will run this later. Thank you

Report •

#6
August 22, 2013 at 14:26:53
It's really not a problem, I just wanted to be able to give you the best possible solution for your issue!

Law of Logical Argument: Anything is possible if you don't know what you're talking about.


Report •

#7
August 22, 2013 at 14:31:42
It worked PERFECTLY!!!!! Thanks you kind person

Report •


Ask Question