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

 

[ExcelGirl1988]

I'm struggling to place a copy of my workbook in a dropbox, I have checked the guidelines but still struggling, could you help with this?

 

[ExcelGirl1988]

I have only been able to copy some sample data to HTML to paste into this message as below, let me know if you want anything different:

Excel 2016 (Windows) 32 bit

	A	B	C	D	E	F
1	School Name	Date	Complaint	Follow Up	Logged by	Status
2	Test School 2	12-06-17	Complaint about policy	Test	Anon	C
3	Test School 2	03-10-17	Complaint about bullying	Test	Anon	P
4	Test School 2	26-11-18	Complaint about the school	Test	Anon	C

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Test 2​

 

[dmt32]

does this help

https://www.dropbox.com/help/business/adding-place-microsoft-office

Dave

 

[dmt32]

Try this

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, 2).End(xlUp).Row
            With ws.Cells(i, 2)
            If IsDate(.Value) Then
                myDate = DateValue(.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(, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column).Copy _
                        Destination:=wsSummary.Cells(erow, 1)
                    End If
                End If
                End If
            End With
            Application.CutCopyMode = False
            Next i
        End If
     Next ws

Dave

 

[ExcelGirl1988]

I have enclosed a link to my dropbox with the test workbook for you to have a look at as the code is still not working.


EDIT:
Removed link at OP's request

 

[dmt32]

I would take that down as it's showing your email also requires password