Fetch Data from multiple sheets based on criteria VBA

**Raj Kumar** · 03-01-2012, 12:37 PM

Hello Excelfox community,

No I again need a help in Excel.

There are 7 sheets in my workbook. Sheet1 to Sheet6 contains data. 7th sheet is called "Find".

I have placed a text box field in 'Find' sheet, which allowed multiline with enterkeybehaviour. So user can enter multiple lines. What I am trying to do is,

There is a combo box which contains only 2 items, "Purchase", "Sales".

If user select "Purchase" need to SEARCH the entries entered in text box (multiline) in Sheet3 & Sheet4 column_F, If user enter 10 lines, needs to look for these 10 items. If found anything, then copy all the found rows data (Sheet3!A:G, Sheet4!A:G) in the find sheet. If possible to SORT by column B. Sound like "Merge found records from two sheets in to a single sheet"

Also if possible enter a sheet name where these records found in the last column in 'Find' sheet. eg: in Col_H if ThisRow item found in Shee3, label as Sheet3, if from Sheet4 label as Sheet4

If user select "Sales" need to SEARCH the entries entered in text box (multiline) only in Sheet4 column_F, If found anything, then copy all the found rows data (A:L) in the find sheet. If possible to SORT by column B

In Sheet3, 4 & 5 data starts from Row 7 to down. So needs to look it for dynamically. also in 'Find' sheet data to be placed in row 7 to down.

I really appreciate your assistance

Raj

**Raj Kumar** · 03-02-2012, 01:18 AM

Thank you Admin for this works great.

Is it possible to SEARCH for text box entries, instead of it's actual values = sheets.

eg: if i enter:

231, xt249, text120, text

Search for these items in column_F then copy rows to Find sheet. Same like ISNUMBER(SEARCH(txtbox.value,InSheets)) also keep the source format?

Instead of Private Sub ComboBox1_Change(), possible to make it as SUB for a button. So users can select the sheets, enter textbox entries then can click on the button.

Thanks ton again for your help

**Admin** · 03-02-2012, 08:04 AM

Hi Raj,

Please find the attachment.

**Admin** · 03-02-2012, 09:01 AM

Hi Raj,

Try this. Assign this macro on a button.

Code:

Sub SearchData()
    
    Dim strComboSelection       As String
    Dim lngIndex    As Long, c  As Long
    Dim ShtsPuchase, ShtSales   As String
    Dim ka, k(), i As Long, n   As Long
    Dim x, j  As Long, r        As Long
    Dim m As Long, SearchKeys   As String
    
    
    ShtsPuchase = Array("Sheet3", "Sheet4") '<< adjust sheet names
    ShtSales = "Sheet5"                     '<< adjust sheet names
    
    SearchKeys = Worksheets("find").TextBox1.Value
    If Len(SearchKeys) Then
        SearchKeys = "{""" & Replace(Replace(SearchKeys, Chr(10), """;"""), Chr(13), vbNullString) & """}"
        With Worksheets("find").ComboBox1
            lngIndex = .ListIndex
            strComboSelection = LCase$(.List(lngIndex, 0))
        End With
        
        Select Case strComboSelection
            Case "purchase"
                ReDim k(1 To 1000, 1 To 8)
                n = 1
                For j = LBound(ShtsPuchase) To UBound(ShtsPuchase)
                    With Worksheets(ShtsPuchase(j))
                        r = .Range("a" & .Rows.Count).End(xlUp).Row
                        ka = .Range("a7:g" & r)
                    End With
                    For c = 1 To UBound(ka, 2): k(1, c) = ka(1, c): Next: k(1, c) = "Label"
                    For i = 2 To UBound(ka, 1)
                        x = False
                        x = Evaluate("isnumber(lookup(9.9999e+307,search(""" & ka(i, 6) & """," & SearchKeys & ")))")
                        If x Then
                            n = n + 1
                            For c = 1 To UBound(ka, 2)
                                k(n, c) = ka(i, c)
                            Next: k(n, c) = ShtsPuchase(j)
                        End If
                    Next
                    Erase ka
                Next
            Case "sales"
                ReDim k(1 To 1000, 1 To 12)
                n = 1
                With Worksheets(ShtSales)
                    r = .Range("a" & .Rows.Count).End(xlUp).Row
                    ka = .Range("a7:l" & r)
                End With
                For c = 1 To UBound(ka, 2): k(1, c) = ka(1, c): Next
                For i = 2 To UBound(ka, 1)
                    x = False
                    x = Evaluate("isnumber(lookup(9.9999e+307,search(""" & ka(i, 6) & """," & SearchKeys & ")))")
                    If x Then
                        n = n + 1
                        For c = 1 To UBound(ka, 2)
                            k(n, c) = ka(i, c)
                        Next
                    End If
                Next
        End Select
    
        If n Then
            Application.ScreenUpdating = False
            With Worksheets("Find")
                .Range("a7", .Cells(7, 1).SpecialCells(11)).ClearContents
                With .Range("a7").Resize(n, UBound(k, 2))
                    .Value = k
                    .Sort .Cells(2, 2), 1, Header:=1
                    .EntireColumn.AutoFit
                End With
            End With
        Else
            MsgBox "No records found", vbInformation
            With Worksheets("Find")
                .Range("a7", .Cells(7, 1).SpecialCells(11)).ClearContents
            End With
        End If
        Application.ScreenUpdating = True
    End If
    
End Sub

**Raj Kumar** · 03-02-2012, 11:25 PM

Thank you for this Admin.

I am sorry, this still doesn't search like a wildcard. May be I haven't been explained clearly.

Eg: The below are the entries in text box multiline. Combo selection "Purchase"

text710, 313, xt116, 27, 1702

You can see these values found in Sheet3!F21, Sheet3!F29, Sheet4!F18, Sheet3!F12 & Sheet4!F16 for the first 4 items. The last one doesn't found in two sheets. So I like to copy these rows data to Find.

Same like Find command with CTRL+F

Thank you for your assistance Admin.

**Admin** · 03-05-2012, 08:00 AM

Hi,

Replace this

Code:

x = Evaluate("isnumber(lookup(9.9999e+307,search(""" & ka(i, 6) & """," & SearchKeys & ")))")

with

Code:

x = Evaluate("isnumber(lookup(9.9999e+307,search(" & SearchKeys & ",""" & ka(i, 6) & """)))")

**Raj Kumar** · 03-06-2012, 03:15 AM

Admin, awesome.... it works great.

One last question.

Some time user leave just enter key in text box, so it produce a wrong result. Is it possible to check If(LEN(TRIM(textbox1))>0 in SearchKeys

eg: user enter 10 lines. But there may be only 8 or 9 entries. Rest of them they just hit ENTER key: no entries, So CHAR(10) is there. So TRIM the textbox & take only LEN()>1 as SearchKeys

Thank you for your time

**Admin** · 03-06-2012, 07:49 AM

Hi,

Replace

Code:

SearchKeys = "{""" & Replace(Replace(SearchKeys, Chr(10), """;"""), Chr(13), vbNullString) & """}"

with

Code:

x = Split(SearchKeys, Chr(10))
SearchKeys = vbNullString
For j = 0 To UBound(x)
    If Len(Trim$(Replace(x(j), Chr(13), vbNullString))) Then
        SearchKeys = SearchKeys & """;""" & Trim$(Replace(x(j), Chr(13), vbNullString))
    End If
Next
SearchKeys = "{""" & Mid$(SearchKeys, 4) & """}"