S
steve
ron was the man and helped me out by writing this code for me. it goes
through a row of salesman, and makes a new sheet for each salesman. there
are duplicate entries for salesman, so it just adds more columns to that
sheet if the name repeats. i just need one more thing. when it is run
twice, all of the columns are repeated again on each sheet. is it possible
for the sheets to be erased each time and replaced? here is the code:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Lc As Long
Set ws1 = ActiveSheet
For Each cell In ws1.Range("J58:IV58").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(1).Copy ws2.Range("A1")
ws1.Columns(cell.Column).Copy ws2.Range("B1")
ws2.Range("A1").Value = Date
ws2.Columns.AutoFit
Else
Set ws2 = Sheets(cell.Value)
Lc = Lastcol(ws2)
ws1.Columns(cell.Column).Copy ws2.Cells(1, Lc + 1)
ws2.Range("A1").Value = Date
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
through a row of salesman, and makes a new sheet for each salesman. there
are duplicate entries for salesman, so it just adds more columns to that
sheet if the name repeats. i just need one more thing. when it is run
twice, all of the columns are repeated again on each sheet. is it possible
for the sheets to be erased each time and replaced? here is the code:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Lc As Long
Set ws1 = ActiveSheet
For Each cell In ws1.Range("J58:IV58").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(1).Copy ws2.Range("A1")
ws1.Columns(cell.Column).Copy ws2.Range("B1")
ws2.Range("A1").Value = Date
ws2.Columns.AutoFit
Else
Set ws2 = Sheets(cell.Value)
Lc = Lastcol(ws2)
ws1.Columns(cell.Column).Copy ws2.Cells(1, Lc + 1)
ws2.Range("A1").Value = Date
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