userform search

[hussy]

Hi all,
I am new to excel user-form and last couple of days I came up with a user form which consists with "Date, Name, Project, Item, Percentage, Comment". All entries are saved in a sheet call "Data Base".
I want to make a query using combo boxes. I made an another user-form and add combo boxes for "Date, Name, Project,Item,Percentage" and a command button. Now what I want to do is, if I select one or more values form combo boxes and hit command button, filter relevant Data entries from "Data Base " and Show in a new work sheet.

please help me to do this.


thanks in advanced

[mancubus]

hi.
wellcome to VBAX.

you can download sample file here to see how to populate a combobox with unique values from range (uses a named range).
http://www.vbaexpress.com/kb/getarticle.php?kb_id=824


you may play with below code:


Private Sub CommandButton1_Click()

With Worksheets("Data Base")
'http://www.ozgrid.com/forum/showthread.php?t=93705
.AutoFilterMode = False
With .Range("A1")
.AutoFilter
If Len(ComboBox1.Value) > 0 Then
.AutoFilter Field:=1, Criteria1:=ComboBox1.Value
End If
If Len(ComboBox2.Value) > 0 Then
.AutoFilter Field:=2, Criteria1:=ComboBox2.Value
End If
If Len(ComboBox3.Value) > 0 Then
.AutoFilter Field:=3, Criteria1:=ComboBox3.Value
End If
If Len(ComboBox4.Value) > 0 Then
.AutoFilter Field:=4, Criteria1:=ComboBox4.Value
End If
If Len(ComboBox5.Value) > 0 Then
.AutoFilter Field:=5, Criteria1:=ComboBox5.Value
End If
End With

'http://contextures.com/xlautofilter03.html#Copy
'by Tom Ogilvy
Dim rng As Range, rng2 As Range

With .AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
Set rng = .AutoFilter.Range
'option1: With headers:
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
'option2: without headers:
'rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Worksheets("Sheet2").Range("A1")
End If
.ShowAllData
End With

End Sub

[hussy]

Hi, I tried with this code and I came-up with a problem. I only selected a value for combobox2 and then hit command button. Even though there is number of similar records in data base, "no data to copy" message appears.
What could be the reason for that

[mancubus]

hi.
that's related with date and percent conversion.

here's a workaround and a sample file.
uses five named ranges for 5 criteria:
Date : Date
Name : String
Project: String
Item: String
Percentage: Number (formatted as 0%. so change number format of crit in the code to suit your actual data)


goes to std module:

Sub OpenUF()
UserForm1.Show
End Sub

Function UniqueArray(anArray As Variant) As Variant

'http://www.vbaexpress.com/forum/showthread.php?t=24917
'Requires, Tools > Reference > Microsoft Scripting Runtime, scrrun.dll

Dim d As New Scripting.Dictionary, a As Variant

With d
.CompareMode = TextCompare
For Each a In anArray
If Not Len(a) = 0 And Not .Exists(a) Then
.Add a, CStr(a) 'Nothing
End If
Next a
UniqueArray = d.keys
End With

Set d = Nothing

End Function



goes to userform's code module

Option Explicit

Dim FArray()
Dim DataList As Range
Dim MyList As String
Dim dDate As Date

Private Sub UserForm_Initialize()

'rDate
MyList = "rDate"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox1.List() = FArray

'rName
MyList = "rName"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox2.List() = FArray

'rProj
MyList = "rProj"
Set DataList = Range(MyList)
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox3.List() = FArray

'rItem
MyList = "rItem"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox4.List() = FArray

'rPerc
MyList = "rPerc"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox5.List() = FArray

End Sub


Private Sub CommandButton1_Click()

Dim rng As Range, rng2 As Range

With Worksheets("Data Base")
'http://www.ozgrid.com/forum/showthread.php?t=93705
.AutoFilterMode = False
With .Range("A1")
.AutoFilter
If Len(ComboBox1.Value) > 0 Then
If IsDate(ComboBox1.Value) Then
dDate = DateSerial(Year(ComboBox1.Value), Month(ComboBox1.Value), Day(ComboBox1.Value))
End If
.AutoFilter Field:=1, Criteria1:="=" & dDate
End If
If Len(ComboBox2.Value) > 0 Then .AutoFilter Field:=2, Criteria1:=ComboBox2.Value
If Len(ComboBox3.Value) > 0 Then .AutoFilter Field:=3, Criteria1:=ComboBox3.Value
If Len(ComboBox4.Value) > 0 Then .AutoFilter Field:=4, Criteria1:=ComboBox4.Value
If Len(ComboBox5.Value) > 0 Then .AutoFilter Field:=5, Criteria1:="=" & Format(ComboBox5.Value, "0%")
End With
'http://contextures.com/xlautofilter03.html#Copy
'by Tom Ogilvy
With .AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
Worksheets("Sheet2").Cells.Clear
Set rng = .AutoFilter.Range
'option1: With headers:
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
'option2: without headers:
'rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Worksheets("Sheet2").Range("A1")
End If
.AutoFilterMode = False
End With

End Sub


Private Sub CommandButton2_Click()
Unload Me
End Sub


Sub BubbleSort(MyArray As Variant)

Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim temp As String
Dim List As String

First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = temp
End If
Next j
Next i
End Sub

[hussy]

Thanks for the reply and now I am getting an error. it says
"Run time error '1004:
Method 'Range' of object'_Global' failed "

What could be the reason for that? Sorry for bothering you. I am extremely new to the VB coding and I am still learning. I Paste my codes for your information.. It will be easy for you to find the error.
Thanks again and appreciate your help.



===============my userform2 code as fallows====================

Option Explicit

Dim FArray()
Dim DataList As Range
Dim MyList As String
Dim dDate As Date


'combo box
Private Sub UserForm_Initialize()
'Macro Purpose: To populate a combobox with data from
' a worksheet range

Dim cbtarget As MSForms.ComboBox

Dim rngSource As Range


'Set reference to the range of data to be filled
'Set rngSource = Worksheets("Sheet4").Range("A1:A15")
'Set rngSource = Workbooks("test.xlsx").Worksheets("Data Base").Range("b:b")
Set rngSource = Worksheets("Data Base").Range("b:b")


'Fill the listbox
Set cbtarget = Me.ComboBox1
With cbtarget
'Insert the range of data supplied
.List = rngSource.Cells.Value
'--------------------------------------------------

Dim cbtarget2 As MSForms.ComboBox
Dim rngSource2 As Range
'Set rngSource2 = Workbooks("test.xlsx").Worksheets("item").Range("a:a")
Set rngSource2 = Worksheets("item").Range("a:a")

'Fill the listbox
Set cbtarget2 = Me.ComboBox2
With cbtarget2
'Insert the range of data supplied
.List = rngSource2.Cells.Value
End With


'--------------------------------------------------

Dim cbtarget3 As MSForms.ComboBox
Dim rngSource3 As Range
'Set rngSource3 = Workbooks("test.xlsx").Worksheets("item").Range("b:b")
Set rngSource3 = Worksheets("item").Range("b:b")

'Fill the listbox
Set cbtarget3 = Me.ComboBox3
With cbtarget3
'Insert the range of data supplied
.List = rngSource3.Cells.Value
End With

'--------------------------------------------------

Dim cbtarget4 As MSForms.ComboBox
Dim rngSource4 As Range
'Set rngSource4 = Workbooks("test.xlsx").Worksheets("item").Range("c:c")
Set rngSource4 = Worksheets("item").Range("c:c")

'Fill the listbox
Set cbtarget4 = Me.ComboBox4
With cbtarget4
'Insert the range of data supplied
.List = rngSource4.Cells.Value
End With


'--------------------------------------------------

Dim cbtarget5 As MSForms.ComboBox
Dim rngSource5 As Range
'Set rngSource5 = Workbooks("test.xlsx").Worksheets("item").Range("d:d")
Set rngSource5 = Worksheets("item").Range("d:d")

'Fill the listbox
Set cbtarget5 = Me.ComboBox5
With cbtarget5
'Insert the range of data supplied
.List = rngSource5.Cells.Value
End With
End With


'by mancubus

'rDate
MyList = "rDate"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox1.List() = FArray

'rName
MyList = "rName"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox2.List() = FArray

'rProj
MyList = "rProj"
Set DataList = Range(MyList)
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox3.List() = FArray

'rItem
MyList = "rItem"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox4.List() = FArray

'rPerc
MyList = "rPerc"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox5.List() = FArray

End Sub


Private Sub CommandButton1_Click()

Dim rng As Range, rng2 As Range

With Worksheets("Data Base")

.AutoFilterMode = False
With .Range("A1")
.AutoFilter
If Len(ComboBox1.Value) > 0 Then
If IsDate(ComboBox1.Value) Then
dDate = DateSerial(Year(ComboBox1.Value), Month(ComboBox1.Value), Day(ComboBox1.Value))
End If
.AutoFilter Field:=1, Criteria1:="=" & dDate
End If
If Len(ComboBox2.Value) > 0 Then .AutoFilter Field:=2, Criteria1:=ComboBox2.Value
If Len(ComboBox3.Value) > 0 Then .AutoFilter Field:=3, Criteria1:=ComboBox3.Value
If Len(ComboBox4.Value) > 0 Then .AutoFilter Field:=4, Criteria1:=ComboBox4.Value
If Len(ComboBox5.Value) > 0 Then .AutoFilter Field:=5, Criteria1:="=" & Format(ComboBox5.Value, "0%")
End With

'by Tom Ogilvy
With .AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
Worksheets("Sheet2").Cells.Clear
Set rng = .AutoFilter.Range
'option1: With headers:
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
'option2: without headers:
'rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Worksheets("Sheet2").Range("A1")
End If
.AutoFilterMode = False
End With

End Sub


Private Sub CommandButton2_Click()
Unload Me
End Sub


Sub BubbleSort(MyArray As Variant)

Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim temp As String
Dim List As String

First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = temp
End If
Next j
Next i
End Sub




============my module code as follows=========================

Sub Button4_Click()
UserForm2.Show

End Sub


Function UniqueArray(anArray As Variant) As Variant


'Requires, Tools > Reference > Microsoft Scripting Runtime, scrrun.dll

Dim d As New Scripting.Dictionary, a As Variant

With d
.CompareMode = TextCompare
For Each a In anArray
If Not Len(a) = 0 And Not .Exists(a) Then
.Add a, CStr(a) 'Nothing
End If
Next a
UniqueArray = d.keys
End With

Set d = Nothing

End Function

[mancubus]

i was not able to duplicate your problem.

can you post your workbook.

(minimum post count must be at leat 5, i think, to upload a file.)

ps: post your code within vba tags please.
pps: did you test the file i posted?

[hussy]

I ll upload the file

[hussy]

1

[hussy]

Actually I wanted to create form for Add Data (Data should be saved in another workbook. ) and a Query form.

Zip file is more than 1mb , so I uploaded my file to rapidshare and here is the link (https://rapidshare.com/files/3477359884/Book1.zip).



https://rapidshare.com/files/3477359884/Book1.zip

Thanks

[mancubus]

ok. but we dont have access to rapid in the office.

you may unpload the file with 20-30 rows of data to help understand the data types in the columns.

[hussy]

I think this is what you want. I tried to send you my workbook. But I couldn't reduce the file size. If you can send me your email (trough private message), then I can send you my workbook. It may be very helpful to you to figure out the problem easily.
Thanks




'===========my userform2 code as fallows====================

Option Explicit

Dim FArray()
Dim DataList As Range
Dim MyList As String
Dim dDate As Date


'combo box
Private Sub UserForm_Initialize()
'Macro Purpose: To populate a combobox with data from
' a worksheet range

Dim cbtarget As MSForms.ComboBox

Dim rngSource As Range


'Set reference to the range of data to be filled
'Set rngSource = Worksheets("Sheet4").Range("A1:A15")
'Set rngSource = Workbooks("test.xlsx").Worksheets("Data Base").Range("b:b")
Set rngSource = Worksheets("Data Base").Range("b:b")


'Fill the listbox
Set cbtarget = Me.ComboBox1
With cbtarget
'Insert the range of data supplied
.List = rngSource.Cells.Value
'--------------------------------------------------

Dim cbtarget2 As MSForms.ComboBox
Dim rngSource2 As Range
'Set rngSource2 = Workbooks("test.xlsx").Worksheets("item").Range("a:a")
Set rngSource2 = Worksheets("item").Range("a:a")

'Fill the listbox
Set cbtarget2 = Me.ComboBox2
With cbtarget2
'Insert the range of data supplied
.List = rngSource2.Cells.Value
End With


'--------------------------------------------------

Dim cbtarget3 As MSForms.ComboBox
Dim rngSource3 As Range
'Set rngSource3 = Workbooks("test.xlsx").Worksheets("item").Range("b:b")
Set rngSource3 = Worksheets("item").Range("b:b")

'Fill the listbox
Set cbtarget3 = Me.ComboBox3
With cbtarget3
'Insert the range of data supplied
.List = rngSource3.Cells.Value
End With

'--------------------------------------------------

Dim cbtarget4 As MSForms.ComboBox
Dim rngSource4 As Range
'Set rngSource4 = Workbooks("test.xlsx").Worksheets("item").Range("c:c")
Set rngSource4 = Worksheets("item").Range("c:c")

'Fill the listbox
Set cbtarget4 = Me.ComboBox4
With cbtarget4
'Insert the range of data supplied
.List = rngSource4.Cells.Value
End With


'--------------------------------------------------

Dim cbtarget5 As MSForms.ComboBox
Dim rngSource5 As Range
'Set rngSource5 = Workbooks("test.xlsx").Worksheets("item").Range("d:d")
Set rngSource5 = Worksheets("item").Range("d:d")

'Fill the listbox
Set cbtarget5 = Me.ComboBox5
With cbtarget5
'Insert the range of data supplied
.List = rngSource5.Cells.Value
End With
End With


'by mancubus

'rDate
MyList = "rDate"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox1.List() = FArray

'rName
MyList = "rName"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox2.List() = FArray

'rProj
MyList = "rProj"
Set DataList = Range(MyList)
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox3.List() = FArray

'rItem
MyList = "rItem"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox4.List() = FArray

'rPerc
MyList = "rPerc"
Set DataList = Range(MyList)
FArray = DataList.Value
FArray = UniqueArray(FArray)
Call BubbleSort(FArray)
ComboBox5.List() = FArray

End Sub


Private Sub CommandButton1_Click()

Dim rng As Range, rng2 As Range

With Worksheets("Data Base")

.AutoFilterMode = False
With .Range("A1")
.AutoFilter
If Len(ComboBox1.Value) > 0 Then
If IsDate(ComboBox1.Value) Then
dDate = DateSerial(Year(ComboBox1.Value), Month(ComboBox1.Value), Day(ComboBox1.Value))
End If
.AutoFilter Field:=1, Criteria1:="=" & dDate
End If
If Len(ComboBox2.Value) > 0 Then .AutoFilter Field:=2, Criteria1:=ComboBox2.Value
If Len(ComboBox3.Value) > 0 Then .AutoFilter Field:=3, Criteria1:=ComboBox3.Value
If Len(ComboBox4.Value) > 0 Then .AutoFilter Field:=4, Criteria1:=ComboBox4.Value
If Len(ComboBox5.Value) > 0 Then .AutoFilter Field:=5, Criteria1:="=" & Format(ComboBox5.Value, "0%")
End With

'by Tom Ogilvy
With .AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
Worksheets("Sheet2").Cells.Clear
Set rng = .AutoFilter.Range
'option1: With headers:
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
'option2: without headers:
'rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Worksheets("Sheet2").Range("A1")
End If
.AutoFilterMode = False
End With

End Sub


Private Sub CommandButton2_Click()
Unload Me
End Sub


Sub BubbleSort(MyArray As Variant)

Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim temp As String
Dim List As String

First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = temp
End If
Next j
Next i
End Sub




'============my module code as follows=========================
'module 10
Sub Button4_Click()
UserForm2.Show

End Sub


Function UniqueArray(anArray As Variant) As Variant


'Requires, Tools > Reference > Microsoft Scripting Runtime, scrrun.dll

Dim d As New Scripting.Dictionary, a As Variant

With d
.CompareMode = TextCompare
For Each a In anArray
If Not Len(a) = 0 And Not .Exists(a) Then
.Add a, CStr(a) 'Nothing
End If
Next a
UniqueArray = d.keys
End With

Set d = Nothing
End Function

'-------------Module1

Sub ShowIt()

Calendar.Show

End Sub

'-----------Module9

[mancubus]

ok. im home and downloaded your file.

your file is too large because you created excel tables from entire columns.

file is attached.

UF5 is my thing.

tested and its working.


ps: same file. i only converted tables to ranges. see the diffrence in sizes.
:hi:

[hussy]

Hi,
Again I got following problem. Sorry for bothering you...


Userform5- when I try to filter data with Date , it says "no data to copy" even though there are some records in the database .


I have one more thing to clarify:
I want to keep data entry form,filter form separate workbook (let say workbook1) and the all the other things (Data base sheet and Item sheet) in another workbook (let say workbook2). As I learnt last couple of days,

Set rngSource = Worksheets("item").Range("c2:c1048576") should be changed to
Set rngSource = Workbooks("workbook2").Worksheets("item").Range("c2:c1048576").

But the problem is, I have to open both file to work with forms. I don't want to open workbook2. As I understand there are no way other than opening workbook2. I think the best way to do it, when the forms open, workbook should open automatically, but workbook should not appears to the user(need to hide from the user). What do you think? Problem is I don't know the code for that. I tried to find. but I couldn't.
Could you please tell me the solution for that.





'to enter data into another workbook

Set rngSource = Worksheets("item").Range("c2:c1048576")
'should be changed to
Set rngSource = Workbooks("bookname").Worksheets("item").Range("c2:c1048576").

[ssmithjhon]

I Updated...

Thanks to sharing........

[frank_m]

For the issue where you get the pop up "no data to copy"
You might try this trick I got from Xld to deal with different regional settings.

Change this line:
dDate = DateSerial(Year(ComboBox1.Value), Month(ComboBox1.Value), Day(ComboBox1.Value))

To this:

dDate = Format(DateSerial(Year(ComboBox1.Value), Month(ComboBox1.Value), _
Day(ComboBox1.Value)), Cells(2, 2).NumberFormat)

[hussy]

Hi Frank,
I changed the code as you said. but it doesnt work for me

[mancubus]

see attached files. one is for data base, the other is for data entry and filtering

tested and it works.

after entering data or filtering DataBaseFile is closed. reopen to see the results.

[mancubus]

dbfile

[hussy]

dbfile

Hi mancubus,

Thank you very much for the project. It works brilliantly (except the "date" filter , when I try to search using a date..it always says "no data to copy" ). Could you please check it again for me.

Thank you very much again.

[mancubus]

you're wellcome hussy.

you should play with date filter...


Dim dDate As Date
Dim lDate As Long


If Len(ComboBox1.Value) > 0 Then
If IsDate(ComboBox1.Value) Then
dDate = DateSerial(Year(ComboBox1.Value), Month(ComboBox1.Value), _
Day(ComboBox1.Value))
lDate = dDate
End If
.AutoFilter Field:=2, Criteria1:="=" & lDate
End If



another approach could be...


Dim lDate As Long


If Len(ComboBox1.Value) > 0 Then
If IsDate(ComboBox1.Value) Then
lDate = CLng(DateValue(ComboBox1.Value))
End If
.AutoFilter Field:=2, Criteria1:="=" & lDate
End If