teodormircea
09-30-2008, 03:42 AM
Hello every one
I'm tring to modify an macros to add more combobox to have more columns to filter and criteria.
I found this macros her, but i'm not so good modifying it.
Her the userform code:
Option Explicit
Private Sub CommandButton1_Click()
Dim rng As Range
Dim ctrl, ctrl1 As MSForms.Control
Dim Field As String
Field = ComboBox1.ListIndex + 1
Field = ComboBox2.ListIndex + 1
Field = ComboBox3.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 Left(ctrl1.Name, 4) = "Text" Then
If ctrl.Value And ctrl1.Value <> "" Then
CreateSheet ctrl.Value, ctrl1.Value
FilterAndCopy rng, ctrl.Value, Field
FilterAndCopy1 rng, ctrl1.Value, Field
rng.AutoFilter
End If
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
Me.ComboBox2.AddItem Cel.Text
Me.ComboBox3.AddItem Cel.Text
Next
ComboBox1.ListIndex = 0
ComboBox2.ListIndex = 0
ComboBox3.ListIndex = 0
Set Cel = Nothing
Set FillRange = Nothing
End Sub
and the module code
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 FilterAndCopy1(rng As Range, Choice1 As String, Field As String)
Dim FiltRng As Range
Worksheets(Choice).Cells.ClearContents
rng.AutoFilter Field:=Field, Criteria2:=Choice1
On Error Resume Next
Set FiltRng = rng.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
FiltRng.Copy Worksheets(Choice1).Range("B1")
Set FiltRng = Nothing
End Function
Function CreateSheet(Choice, Choice1 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 + Choice1
On Error GoTo 0
End Function
also i attached the example file.
I will appreciate your help
I'm tring to modify an macros to add more combobox to have more columns to filter and criteria.
I found this macros her, but i'm not so good modifying it.
Her the userform code:
Option Explicit
Private Sub CommandButton1_Click()
Dim rng As Range
Dim ctrl, ctrl1 As MSForms.Control
Dim Field As String
Field = ComboBox1.ListIndex + 1
Field = ComboBox2.ListIndex + 1
Field = ComboBox3.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 Left(ctrl1.Name, 4) = "Text" Then
If ctrl.Value And ctrl1.Value <> "" Then
CreateSheet ctrl.Value, ctrl1.Value
FilterAndCopy rng, ctrl.Value, Field
FilterAndCopy1 rng, ctrl1.Value, Field
rng.AutoFilter
End If
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
Me.ComboBox2.AddItem Cel.Text
Me.ComboBox3.AddItem Cel.Text
Next
ComboBox1.ListIndex = 0
ComboBox2.ListIndex = 0
ComboBox3.ListIndex = 0
Set Cel = Nothing
Set FillRange = Nothing
End Sub
and the module code
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 FilterAndCopy1(rng As Range, Choice1 As String, Field As String)
Dim FiltRng As Range
Worksheets(Choice).Cells.ClearContents
rng.AutoFilter Field:=Field, Criteria2:=Choice1
On Error Resume Next
Set FiltRng = rng.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
FiltRng.Copy Worksheets(Choice1).Range("B1")
Set FiltRng = Nothing
End Function
Function CreateSheet(Choice, Choice1 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 + Choice1
On Error GoTo 0
End Function
also i attached the example file.
I will appreciate your help