Solved: .Find method to locate >= date from message input

[kilbey1]

I'm trying to re-use some existing code that allows me to find a term in a cell and then copy the entire row to another sheet. In this scenario, I have a date in the format 12/19/2008. I'd like to input a date in a message box (12/15/2008) and, in range B:B, find all instances that are equal or greater than 12/15/2008.

Can I re-use the find method to do this, or is there a different way I'll have to approach it?


Sub FindUpdates()
Dim intS As Integer
Dim rngC As Range
Dim strDate As String
Dim LastRow As Long
Dim i As Long
Dim wSht As Worksheet
Dim destSht As Worksheet
Application.ScreenUpdating = False

intS = 2
Set wSht = Worksheets("Open")
Set destSht = Worksheets("Updates")

strDate = Application.InputBox(Prompt:="Find Latest Issues As Of:", _
Title:="DATE FIND", Default:=Format(Date, "Short Date"), Type:=2)
'cancel
If strDate = "False" Then Exit Sub

strToFind = strDate
destSht.Range("A2:P4000").Delete

If IsDate(strDate) Then

With wSht.Range("B2:B2000")
Set rngC = .Find(what:=strToFind, LookIn:=xlValues, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
rngC.EntireRow.Copy destSht.Cells(intS, 1)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With

End If
End Sub

[mikerickson]

If each column has a unique header and there are no blank rows, you could use Advanced Filter with the 2 row X 1 column Criteria Range

Date
>12/14/2008


When using the 'Copy to another location' feature, the destination sheet needs to be active when Advanced Filter is pressed.

[kilbey1]

I'm not sure how that would look; here's my stab:


wSht.Range("B2:B4000").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("B2:B4000"), CopyToRange:=Range(destSht.Cells(intS, 1)), Scroll:=True, Unique:=False


But if the destination sheet need to be active, I'm not sure this would be the best solution for me anyway. I have a summary page (sheet1) that has various macros tied to buttons that will allow me to copy over data from other pages, so when I click a button sheet3 gets populated, another button and sheet4 gets populated, etc -- so I never need to have my destination sheets active. They are all based on a similar macro that you see here, but in these other cases, all I really need to find is the exact wording (so strToFind = strDate becomes strToFind = "Needs Analysis", and all findings would populate the "Needs Analysis" worksheet based on that criteria).

Having said that...should I ditch the Find method and try something different?

Thanks,
Eve

[mikerickson]

I should have been clearer. The destination sheet only needs to be active if Advanced Filter is called from the user interface. When called from VB, any sheet can be active.

The attached has an example of how it might be used.
Criteria for other kinds of matches are given for examples, but commented out.Sub test()
Dim sourceRange As Range
Dim destinationRange As Range
Dim critRange As Range

Set sourceRange = ThisWorkbook.Sheets("Sheet1").Range("A1:C6"): Rem adjust
Set destinationRange = ThisWorkbook.Sheets("Sheet2").Range("A1"): Rem adjust

Rem destinationRange has same column count as sourcerange
Set destinationRange = destinationRange.Resize(1, sourceRange.Columns.Count)
destinationRange.EntireColumn.ClearContents

Rem find unused range for criteria
With sourceRange.Parent
Set critRange = .Cells(1, .UsedRange.Column + .UsedRange.Columns.Count + 1).Resize(2, 1)
End With

Rem fill criteria range
With critRange
.Cells(1, 1) = "Date"
.Cells(2, 1) = "'>6/1/2007"
End With

Rem criteria for exact match
'With critRange
' .Cells(1, 1) = "Department"
' .Cells(2, 1) = "'=Shipping"
'End With

Rem criteria for partial match
'With critRange
' .Cells(1, 1) = "Department"
' .Cells(2, 1) = "*Ship*"
'End With

sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critRange, CopyToRange:=destinationRange, Unique:=False

critRange.EntireColumn.Delete
End Sub

[kilbey1]

Below is my revised (and cleaned up) code. When I get to this line: .Cells(1, 2) = "Logged", it tells me an object is required. So I added wSht to both methods and I noticed it's overwriting .cells(2, 2) now with the second critRng value. Any thoughts on this?

Second issue...how to write .Cells(2, 2) = "'>12/10/2008" to be dynamic such that strDate is passed to the second Cells method? I tried .Cells(2, 2) = "'>=strDate" but of course that would be wrong...perhaps .Cells(2, 2) = "'>="+strDate or maybe .Cells(2, 2) = "'>'="+strDate?


Sub FindUpdates()
Dim wSht As Worksheet
Dim destSht As Worksheet
Dim srcRng As Range
Dim destRng As Range
Dim critRng As Range
Dim strDate As String
Application.ScreenUpdating = False

Set wSht = Worksheets("Open")
Set destSht = Worksheets("Updates")
Set srcRng = wSht.Range("B2:B4000")
Set destRng = destSht.Range("A2:P4000")

strDate = Application.InputBox(Prompt:="Find Latest Issues As Of:", _
Title:="DATE FIND", Default:=Format(Date, "Short Date"), Type:=2)
'cancel
strToFind = strDate
If strDate = "False" Then Exit Sub
If Not IsDate(strDate) Then Exit Sub

If IsDate(strDate) Then

destRng.Delete

'find unused range For criteria
With srcRng.Parent
Set critRng = .Cells(1, .UsedRange.Column + .UsedRange.Columns.Count + 1).Resize(2, 1)
End With

'fill criteria range
With critRange
.Cells(1, 2) = "Logged"
.Cells(2, 2) = "'>12/10/2008"
End With

srcRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=critRng, CopyToRange:=dstRng, Unique:=False
'critRange.EntireColumn.Delete

End If
End Sub

[mikerickson]

It since critRange is only 1 column wide, it should be .Cells(1,1)

[kilbey1]

I had a difficult time getting that to work for some reason; however, I did come to a solution and am posting it here.


Sub FindUpdates()
Dim wSht As Worksheet
Dim destSht As Worksheet
Dim srcRng As Range
Dim destRng As Range
Const cColumnDate = 2 'COLUMN=B
Dim myRow As Integer
Dim vCellValue As Variant

Set wSht = Worksheets("Open")
Set destSht = Worksheets("Updates")
Set srcRng = wSht.Range("B2:B4000")
Set destRng = destSht.Range("A2:P4000")

Application.ScreenUpdating = False

strDate = Application.InputBox(Prompt:="Find Latest Issues As Of:", _
Title:="DATE FIND", Default:=Format(Date, "Short Date"), Type:=2)

'empty
If strDate = "False" Then Exit Sub
'not a date
If Not IsDate(strDate) Then Exit Sub

If IsDate(strDate) Then

destRng.Delete
strDate = CDate(strDate)

'traverse cells, from last used cell to first one
For myRow = wSht.UsedRange.Rows.Count To 1 Step -1

'get cell value
vCellValue = wSht.Cells(myRow, cColumnDate)
'is value a date?
If IsDate(vCellValue) Then
'compare date, copy row
If vCellValue >= strDate Then
wSht.Rows(myRow).Copy destSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End If

Next myRow

End If

Worksheets("Stats").Range("E10").Value = strDate
Worksheets("Stats").Range("E22").Value = strDate

End Sub