When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
..Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
..Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
..Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
..Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
..Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
..Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
..Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
..Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
..Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
..Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
..Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
..Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

Simpliest method is to assume the sheet already exists. Don't care about the
first time.
chnage from
With wsh.Parent.Worksheets.Add

to
with wsh
wsh.Cells.ClearContents

"Mekinnik" wrote:

When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
.Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
.Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
.Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
.Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
.Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
.Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
.Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
.Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
.Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
.Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
.Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
.Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

Sorry Joel,
It didn't work, what it did was clear the contents of my database 'ProCode'
not the newly created sheet? Any more suggestion?

"Joel" wrote:

Simpliest method is to assume the sheet already exists. Don't care about the
first time.
chnage from
With wsh.Parent.Worksheets.Add

to
with wsh
wsh.Cells.ClearContents

"Mekinnik" wrote:

When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
.Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
.Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
.Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
.Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
.Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
.Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
.Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
.Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
.Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
.Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
.Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
.Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

Sorry. Name the destination worksheet with a name

chnage from
With wsh.Parent.Worksheets.Add

to
with Sheets("Dest Sheet")
.Cells.ClearContents



"Mekinnik" wrote:

Sorry Joel,
It didn't work, what it did was clear the contents of my database 'ProCode'
not the newly created sheet? Any more suggestion?

"Joel" wrote:

Simpliest method is to assume the sheet already exists. Don't care about the
first time.
chnage from
With wsh.Parent.Worksheets.Add

to
with wsh
wsh.Cells.ClearContents

"Mekinnik" wrote:

When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
.Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
.Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
.Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
.Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
.Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
.Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
.Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
.Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
.Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
.Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
.Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
.Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

Personally, if I don't care about the data on any existing worksheet with the
same name, I'd delete that sheet and create from scratch.


on error resume next 'in case the worksheet doesn't exist
application.displayalerts = false 'stop the "are you sure" prompt
wsh.parent.worksheets(SearchFor).delete 'delete the sheet
application.displayalerts = true 'turn on the alerts
on error goto 0 'turn error checking back on

.....

With wsh.Parent.Worksheets.Add
.....


Mekinnik wrote:

When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
.Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
.Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
.Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
.Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
.Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
.Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
.Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
.Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
.Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
.Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
.Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
.Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

--

Dave Peterson

Joel,
I need to trap the error and determine if the sheet already exists and if
so then delete it and create the new one with the new data.

"Joel" wrote:

Sorry. Name the destination worksheet with a name

chnage from
With wsh.Parent.Worksheets.Add

to
with Sheets("Dest Sheet")
.Cells.ClearContents



"Mekinnik" wrote:

Sorry Joel,
It didn't work, what it did was clear the contents of my database 'ProCode'
not the newly created sheet? Any more suggestion?

"Joel" wrote:

Simpliest method is to assume the sheet already exists. Don't care about the
first time.
chnage from
With wsh.Parent.Worksheets.Add

to
with wsh
wsh.Cells.ClearContents

"Mekinnik" wrote:

When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
.Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
.Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
.Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
.Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
.Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
.Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
.Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
.Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
.Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
.Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
.Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
.Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

Thank you Dave it works perfectly.

"Dave Peterson" wrote:

Personally, if I don't care about the data on any existing worksheet with the
same name, I'd delete that sheet and create from scratch.


on error resume next 'in case the worksheet doesn't exist
application.displayalerts = false 'stop the "are you sure" prompt
wsh.parent.worksheets(SearchFor).delete 'delete the sheet
application.displayalerts = true 'turn on the alerts
on error goto 0 'turn error checking back on

.....

With wsh.Parent.Worksheets.Add
.....


Mekinnik wrote:

When I run the current code with newly entered data, it tells me it cannot
created the sheet because it already exists and just creates one named
sheet??. So how can I make it either delete the sheet to write the new sheet
or how do I make it over write the existing sheet with the new data?

Private Sub BtnGo_Click()
Dim rgMatch As Range '''' range of matches
Dim searchFor As String ''' string to search for
Dim wsh As Worksheet ''' where to search
Dim rgToSearch As Range ''' where to search
Dim RgFrom As Range
Dim n As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'copies all data that matches 'T' to new sheet
searchFor = Me.CbxDept.Text
Set wsh = Sheets("Procode")
Set rgToSearch = wsh.Range("M:M")
Set RgFrom = wsh.Range("A1:M1").EntireColumn
n = Int(56 * Rnd + 1)

''' Search all matches
Set rgMatch = FindAll(rgToSearch, searchFor & "*", xlValues, xlWhole)

''' Process matches
If Not rgMatch Is Nothing Then
''' copy specific columns to new sheet
With wsh.Parent.Worksheets.Add
''' copy second column: B-B
Application.Intersect(rgMatch.EntireRow, wsh.Range("B:B")).Copy
.Range("B5")
''' copy third column : C-H
Application.Intersect(rgMatch.EntireRow, wsh.Range("C:C")).Copy
.Range("H5")
''' copy forth column : D-I
Application.Intersect(rgMatch.EntireRow, wsh.Range("D:D")).Copy
.Range("I5")
''' copy fifth column: E-J
Application.Intersect(rgMatch.EntireRow, wsh.Range("E:E")).Copy
.Range("J5")
''' copy sixth column: F-K
Application.Intersect(rgMatch.EntireRow, wsh.Range("F:F")).Copy
.Range("K5")
''' copy seventh column : G-L
Application.Intersect(rgMatch.EntireRow, wsh.Range("G:G")).Copy
.Range("L5")
''' copy eighth column: H-M
Application.Intersect(rgMatch.EntireRow, wsh.Range("H:H")).Copy
.Range("M5")
''' copy ninth column: I-N
Application.Intersect(rgMatch.EntireRow, wsh.Range("I:I")).Copy
.Range("N5")
''' copy tenth column : J-O
Application.Intersect(rgMatch.EntireRow, wsh.Range("J:J")).Copy
.Range("O5")
''' copy eleventh column: K-P
Application.Intersect(rgMatch.EntireRow, wsh.Range("K:K")).Copy
.Range("P5")
''' copy twelveth column: L-Q
Application.Intersect(rgMatch.EntireRow, wsh.Range("L:L")).Copy
.Range("Q5")
''' copy last column: M-A
Application.Intersect(rgMatch.EntireRow, wsh.Range("M:M")).Copy
.Range("A5")
Call FormatHeaders
'''change the tab color randomly and rename sheet
.Tab.ColorIndex = n
.Name = searchFor
End With

End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Private Sub UserForm_Initialize()
Me.CbxDept.Clear
CbxDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(extern al:=True)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub

Public Function FindAll(where As Range, what As Variant, lookIn As
XlFindLookIn, lookAt As XlLookAt) As Range
Dim rgResult As Range
Dim cell As Range
Dim firstAddr As String

With where
Set cell = .Find(what, lookIn:=lookIn, lookAt:=lookAt)
If Not cell Is Nothing Then
firstAddr = cell.Address
Do
''' add cell to result range
If rgResult Is Nothing Then
Set rgResult = cell
Else
Set rgResult = Application.Union(rgResult, cell)
End If
''' find next match
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address < firstAddr
End If
End With

Set FindAll = rgResult
End Function

--

Dave Peterson