M
Mekinnik
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")).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(external:=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
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")).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(external:=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