I'm trying to create VBA that searches a worksheet for a cell in a row that contains a string - it then needs to check the expiry date is within 6 months from today(0 and copy all rows that meet the criteria to another sheet.
Search Worksheet = DELEGATES
String Value = RENEWALS sheet Cell B3
Post Sheet = Sheet2
Sub Renewals()
Dim aLastRow As Long
Dim yResults As Long
Dim xCourse As String
Dim foundRng As Range
aLastRow = Worksheets("DELEGATES").UsedRange.Rows.Count
yResults = Worksheets("Sheet2").UsedRange.Rows.Count
If yResults = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then yResults = 0
End If
xCourse = Worksheets("RENEWALS").Range("B3").Value
Set foundRng = Worksheets("DELEGATES").Range("R1:R" & aLastRow)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To foundRng.Count
If CStr(foundRng(K).Value) Like "*" & xCourse & "*" Then
foundRng(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished"
End Sub
Search Worksheet = DELEGATES
String Value = RENEWALS sheet Cell B3
Post Sheet = Sheet2
Sub Renewals()
Dim aLastRow As Long
Dim yResults As Long
Dim xCourse As String
Dim foundRng As Range
aLastRow = Worksheets("DELEGATES").UsedRange.Rows.Count
yResults = Worksheets("Sheet2").UsedRange.Rows.Count
If yResults = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then yResults = 0
End If
xCourse = Worksheets("RENEWALS").Range("B3").Value
Set foundRng = Worksheets("DELEGATES").Range("R1:R" & aLastRow)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To foundRng.Count
If CStr(foundRng(K).Value) Like "*" & xCourse & "*" Then
foundRng(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished"
End Sub