ExcelGirl1988
New Member
- Joined
- Mar 27, 2017
- Messages
- 44
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:
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:
Code:
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
