new sheet

[Guest]

i did not create the worksheet i am working with. The data is organized so
the headings are by row, not column. For example:


A B C
1 Commision % 8.2 9.3
2 Sales Rep dave bill
3 Job # 1 2


I need to go through row 2, and make a sheet for each salesman. but it
needs to copy the whole column with it. most sheets are set up so these
would be the column headings. i don't want to reorganize the sheet by
transposing the data, but something like that could be hidden in the code if
need be. i'm stuck. so i'd appreciate any help.

THANKS,
Steve

 

[Ron de Bruin]

Hi Steve

Try this one on a copy of your workbook

Sub test()
Dim WSNew As Worksheet
Dim Mysheet As Worksheet
Set Mysheet = ActiveSheet
For Each cell In Range("B2:IV2").SpecialCells(xlConstants)
Set WSNew = Worksheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
Mysheet.Columns(cell.Column).Copy WSNew.Range("A1")
Next
End Sub

 

[Guest]

this code started creating a bunch of sheets. there's only 3 different
salesman. i need it to go through row 57 and filter out the salesman by
name. i should end up with three sheets.

thanks for your help ron

 

[Ron de Bruin]

Hi Steve

Do you have duplicate names in row 2 ?

 

[Guest]

yes, there are 3 salesmen, each one has about 30 jobs

 

[Ron de Bruin]

Ahhaaaa

I will make a example for you this evening

 

[Guest]

thanks a lot man, i really appreciate it.

Ahhaaaa

I will make a example for you this evening

 

[Ron de Bruin]

OK try this tester, copy the macro and both functions in a normal module.
Let me kmow if this is working for you

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Lc As Long

Set ws1 = ActiveSheet
For Each cell In ws1.Range("B2:IV2").SpecialCells(xlConstants)
If SheetExists(cell.Value) = False Then
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = cell.Value
On Error GoTo 0
ws1.Columns(cell.Column).Copy ws2.Range("A1")
ws2.Columns.AutoFit
Else
Set ws2 = Sheets(cell.Text)
Lc = Lastcol(ws2)
ws1.Columns(cell.Column).Copy ws2.Cells(1, Lc + 1)
End If
Next
End Sub


Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

 

[Guest]

it's creating a seperate sheet for every column

OK try this tester, copy the macro and both functions in a normal module.
Let me kmow if this is working for you

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Lc As Long

Set ws1 = ActiveSheet
For Each cell In ws1.Range("B2:IV2").SpecialCells(xlConstants)
If SheetExists(cell.Value) = False Then
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = cell.Value
On Error GoTo 0
ws1.Columns(cell.Column).Copy ws2.Range("A1")
ws2.Columns.AutoFit
Else
Set ws2 = Sheets(cell.Text)
Lc = Lastcol(ws2)
ws1.Columns(cell.Column).Copy ws2.Cells(1, Lc + 1)
End If
Next
End Sub


Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

 

[Ron de Bruin]

Hi Steve

For example :
It will copy all columns with Dave in ws1.Range("B2:IV2") to the same sheet.

Send me a small test workbook private and I look at it for you

 

[Ron de Bruin]

This is working in the workbook you send me Steve
You have the names in Row 57

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Lc As Long

Set ws1 = ActiveSheet
For Each cell In ws1.Range("J57:IV57").SpecialCells(xlConstants)
If SheetExists(cell.Value) = False Then
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = cell.Value
On Error GoTo 0
ws1.Columns(cell.Column).Copy ws2.Range("A1")
ws2.Columns.AutoFit
Else
Set ws2 = Sheets(cell.Value)
Lc = Lastcol(ws2)
ws1.Columns(cell.Column).Copy ws2.Cells(1, Lc + 1)
End If
Next
End Sub


Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function