Search through workbook using macro with several ctiterias

[Kotler]

Hello friends. I’m new member of this forum and I hope that you could help me.
Before describing my issue, I want to admit that I’m not very good at VBA and writing macros, so I do hope that criticism from more experienced member will be avoided. I have done search through internet and could not find macro that would be appropriate for my case.

I’m working with huge file, like 50k-90k records in each sheet, and sometimes sheet number goes up to 10 or even more. My job is to find if these record contain names of certain products: Product1, Product2,…….etc. The min. amount of search terms as a rule is 10 (from Product1 to Product10), but sometimes it goes up to 70.

I’m interesting if it is possible to write a macro that will help me to define if cells in all sheets contains product names(only), if contains copy this name in new workbook. The name of products remain unchanged, but there is a problem with cell value, as sometimes they contain product name in following order: Product1(010170), or like # 22847 Product2, or # Product3 87622. There have been cases where I found these name in texts: There has been 1% decline in sales of Produc1 etc.

Please help me resolve this problem.

Thank you very much

 

[Jing]

This will allow you to search for up to 10 different criteria on any sheet...

press Alt+F11 to access VBA

Insert a new UserForm

the layout can be however you would like... just make sure there is a one ComboBox and 10 text boxes

add two buttons

CommandButton1 & CommandButton2
Search Cancel

Double click on the Userform in any location to access the code and enter the following: (make sure the drop downs on the code sheet are set to UserForm and Initialize)

Option Explicit
Private Sub ComboBox1_Change()
End Sub
Private Sub CommandButton1_Click()
Dim rng As Range
Dim ctrl As MSForms.Control
Dim Field As String
Field = ComboBox1.ListIndex + 1
'Set Error Handling
On Error GoTo ws_exit:
Application.EnableEvents = False
'Set Range
Set rng = ActiveSheet.UsedRange
For Each ctrl In UserForm1.Controls
    If Left(ctrl.Name, 4) = "Text" Then
       If ctrl.Value <> "" Then
            CreateSheet ctrl.Value
            FilterAndCopy rng, ctrl.Value, Field
            rng.AutoFilter
        End If
     End If
Next
Unload Me
Exit Sub
ws_exit:
    Set rng = Nothing
    Application.EnableEvents = True
    Unload Me
End Sub
Private Sub CommandButton2_Click()
'Cancel Button
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim FillRange       As Range
Dim Cel             As Range
Dim iLastRow        As Long
Dim iLastColumn     As Long
 'Find Last Row
iLastRow = 1
 'Find Last Column
iLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
 'Set Range from A1 to Last Row/Column
Set FillRange = Range("A1", Cells(iLastRow, iLastColumn))
            
For Each Cel In FillRange
    Me.ComboBox1.AddItem Cel.Text
Next
    
ComboBox1.ListIndex = 0
    
Set Cel = Nothing
Set FillRange = Nothing
End Sub

Now Insert a new Module and enter the following Code: (Make sure the drop downs on the code shee are set to General & Formshow)

Option Explicit
Sub formshow()
'Show Search Form
UserForm1.Show
End Sub
Function FilterAndCopy(rng As Range, Choice As String, Field As String)
    
    Dim FiltRng As Range
    Worksheets(Choice).Cells.ClearContents
    rng.AutoFilter Field:=Field, Criteria1:=Choice
    On Error Resume Next
    Set FiltRng = rng.SpecialCells(xlCellTypeVisible).EntireRow
    On Error GoTo 0
    FiltRng.Copy Worksheets(Choice).Range("A1")
    Set FiltRng = Nothing
     
End Function
Function CreateSheet(Choice As String)
Dim NewSheet As Worksheet
On Error GoTo Err:
Worksheets(Choice).Select
Exit Function
Err:
Set NewSheet = Worksheets.Add
    On Error Resume Next
    NewSheet.Name = Choice
    On Error GoTo 0
End Function

If you need i can always e-mail you a template to follow...