Need Help with a double search code

[ExcelGirl1988]

Hi,

I have done a couple of codes for different searches, one to search by date and one to search by keyword. In both codes the results are found in the workbook and the rows are copied and pasted into a 'Summary' sheet. I now need to merge these codes together so that I find results between 2 dates and then I need to filter these by a keyword so the results will be between 2 certain dates and only include the keyword I have entered but I am having trouble with the keyword search after the date search, and I was wondering if anyone could help?

The code is below:

Sub Double_Search()
    
    Dim erow As Long, i As Long, instances As Long, lastrow As Long
    Dim myDate As Date, StartDate As Date, EndDate As Date
    Dim ws As Worksheet, wsSummary As Worksheet, sht As Worksheet
    Dim answer As VbMsgBoxResult
    Dim myString As String, firstaddress As String
    Dim c As Range
    Dim mySize As XlLookAt
    Dim found As Boolean
    
    Set wsSummary = ThisWorkbook.Worksheets("Summary")
    
    Application.ScreenUpdating = False
    
    With Worksheets("Home")
        StartDate = .Range("E5").Value
        EndDate = .Range("E6").Value
    End With
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Summary" And ws.Name <> "Home" Then
            Application.CutCopyMode = False
            For i = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            Application.CutCopyMode = False
                myDate = ws.Cells(i, 2)
                If myDate >= StartDate And myDate <= EndDate Then
                    erow = wsSummary.Cells(wsSummary.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    ws.Cells(i, 1).Resize(i, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Copy _
                    Destination:=wsSummary.Cells(erow, 1)
                    Application.CutCopyMode = False
                End If
            Next i
        End If
     Next ws
     
wsSummary.Activate
myString = Application.InputBox("Enter Keyword")
If myString = "" Then Exit Sub
If Len(myString) = 0 Then
            answer = MsgBox("The Search Field Can Not Be Left Blank" _
            & vbLf & vbLf & "Do You Want To Try Again?", vbYesNo + vbQuestion, "Search")
        Else
    If MsgBox("Exact Match Only? " & vbCrLf & vbCrLf & _
            "Yes For Exact Match Of " & myString & vbCrLf & vbCrLf & _
            "No For Any Match Of " & myString, vbYesNo + vbQuestion) = _
            vbYes Then mySize = xlWhole Else mySize = xlPart
    End If
    
With Worksheets("Summary").UsedRange
Set c = .Find(myString, LookIn:=xlValues, LookAt:=mySize, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then firstaddress = c.Address
found = True


Do While c.Address <> firstaddress
Loop
End With


Set sht = ThisWorkbook.Worksheets("Home")
wsSummary.Range("A:F").RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes
Application.ScreenUpdating = True


lastrow = wsSummary.Cells(Rows.Count, "A").End(xlUp).Row - 1


If lastrow = 0 Then
MsgBox "No Complaints Found", , "Search Complete"
Else
answer = MsgBox("There are " & lastrow & " complaints found" & vbNewLine & _
    "Go to Summary sheet now?", vbYesNo, "Search Complete")
If answer = vbYes Then wsSummary.Activate
End If
End Sub

 

[dmt32]

Hi,
Untested but see if these adjustments to your code will do what you want

Set wsSummary = ThisWorkbook.Worksheets("Summary")
    
    Do
    myString = InputBox("Enter Keyword", "Enter Keyword")
'cancel pressed
    If StrPtr(myString) = 0 Then Exit Sub
    Loop Until Len(myString) > 0
    
    If MsgBox("Exact Match Only? " & vbCrLf & vbCrLf & _
            "Yes For Exact Match Of " & myString & vbCrLf & vbCrLf & _
            "No For Any Match Of " & myString, 36) = vbYes Then mySize = xlWhole Else mySize = xlPart
    
    Application.ScreenUpdating = False
    
    With Worksheets("Home")
        StartDate = .Range("E5").Value
        EndDate = .Range("E6").Value
    End With
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsSummary.Name And ws.Name <> "Home" Then
            For i = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            With ws.Cells(i, 2)
                myDate = .Value
                If myDate >= StartDate And _
                myDate <= EndDate And _
                IIf(mySize = xlWhole, UCase(.Value) = UCase(myString), .Value Like "*" & myString) Then
                    erow = wsSummary.Cells(wsSummary.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    ws.Cells(i, 1).Resize(i, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Copy _
                    Destination:=wsSummary.Cells(erow, 1)
                End If
            End With
            Application.CutCopyMode = False
            Next i
        End If
     Next ws

Dave

 

[ExcelGirl1988]

Hi Dave,

Thank you for your code but unfortunately this did not work. When I stepped through the code it jumped from:

myDate = .Value
If myDate >= StartDate And _
myDate <= EndDate And _
IIf(mySize = xlWhole, UCase(.Value) = UCase(myString), .Value Like "*" & myString) Then

to:

End If
End With
Application.CutCopyMode = False
Next i
End If
Next ws

It misses out the part where it is supposed to copy and paste the relevant rows:

erow = wsSummary.Cells(wsSummary.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ws.Cells(i, 1).Resize(i, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Copy _
Destination:=wsSummary.Cells(erow, 1)

 

[dmt32]

Hi,
sorry but had no time to test

try this update to that line

myDate = .Value
                If myDate >= StartDate And _
                myDate <= EndDate And mySize = xlWhole And UCase(.Value) = UCase(myString) Or mySize = xlPart And .Value Like "*" & myString Then

Dave

 

[ExcelGirl1988]

Hi,

Still no joy, I am still quite new to VBA but the code seems to be pulling through the dates and key words ok but for some reason it is not copying the rows that correspond to the dates and keyword.

 

[dmt32]

sorry, I am just glancing at your code as time limited and neglected to apply offset to the search range
Which column does the keyword test apply to?

Dave

 

[ExcelGirl1988]

The keyword search applies to column C

 

[dmt32]

try this

           With ws.Cells(i, 2)
                myDate = .Value
                If myDate >= StartDate And myDate <= EndDate Then
                    If mySize = xlWhole And UCase(.Offset(0, 1).Value) = UCase(myString) Or _
                    mySize = xlPart And .Offset(0, 1).Value Like "*" & myString Then
                     erow = wsSummary.Cells(wsSummary.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                     ws.Cells(i, 1).Resize(i, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Copy _
                        Destination:=wsSummary.Cells(erow, 1)
                    End If
                End If
            End With

Dave

 

[ExcelGirl1988]

Still no luck, not sure what is going wrong with the code, it keeps skipping the copy and paste part

 

[dmt32]

Still no luck, not sure what is going wrong with the code, it keeps skipping the copy and paste part

are you able to place copy of your workbook with some sample data in a dropbox & provide link to it here?

I am time limited but I or maybe another here hopefully will be able to resolve for you

Dave