VBA to check between two dates, compare with today and if true then copy entire data

Option Explicit

Sub Vacheron()
    Dim i As Long, lr As Long
    lr = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lr
        If Date >= Range("G" & i) And Date <= Range("H" & i) Then
            Range("A" & i).EntireRow.Interior.ColorIndex = 3
        End If
    Next i
End Sub

Here is an alternate solution for you

Option Explicit

Sub Vach2()
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Dim i As Long, lr As Long, lr2 As Long
    s1.Range("A1:H1").Copy s2.Range("A1")
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lr
        If Date >= s1.Range("G" & i) And Date <= s1.Range("H" & i) Then
            lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
            s1.Range("A" & i & ":H" & i).Copy
            s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
        End If
    Next i
    Application.CutCopyMode = False
End Sub

Hey Alan,

This code worked for me, the first one didn't, it would just highlight everything with red.

Thanks a lot!

Sub J3v16()
Dim Arr, Data
With Sheet1.Cells(1).CurrentRegion
    .Rows(1).Copy Sheet2.Cells(1)
    Data = Filter(.Parent.Evaluate("transpose(if((" & .Columns(6).Address & ">=""" & Date & """)*(" & .Columns(7).Address & "<=""" & Date & """),row(1:" & .Rows.Count & ")))"), False, 0)
    If UBound(Data) > -1 Then
        Arr = Application.Transpose(Application.Index(.Value, Data, Application.Evaluate("row(1:" & .Columns.Count & ")")))
        With Sheet2
            .Cells(1).Offset(1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
            With .UsedRange: .Borders.Weight = 2: .Columns.AutoFit: End With
        End With
    End If
End With
End Sub

Non looping option...

Sub J3v16()
Dim Arr, Data
With Sheet1.Cells(1).CurrentRegion
    .Rows(1).Copy Sheet2.Cells(1)
    Data = Filter(.Parent.Evaluate("transpose(if((" & .Columns(6).Address & ">=""" & Date & """)*(" & .Columns(7).Address & "<=""" & Date & """),row(1:" & .Rows.Count & ")))"), False, 0)
    If UBound(Data) > -1 Then
        Arr = Application.Transpose(Application.Index(.Value, Data, Application.Evaluate("row(1:" & .Columns.Count & ")")))
        With Sheet2
            .Cells(1).Offset(1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
            With .UsedRange: .Borders.Weight = 2: .Columns.AutoFit: End With
        End With
    End If
End With
End Sub

Originally Posted by Vacheron23

Hey Sintek,

Thanks, for whatever reason it is missing out some entries
Any thoughts?

Works for sample...which are you testing against...Are the dates actual dates...

Hello.
Due to the regional configuration issue on my computer, what was proposed in post #5 does not work for me. So I expose another way that -it seems to me- works in all configurations:

PHP Code: 

Sub myFilter()
Dim a, Q&, i&, R&, j%
With Sheets("Sheet1").Range("A1").CurrentRegion
  a = .Value: Q = UBound(a): .Rows(1).Copy Sheets("Sheet2").Range("A1")
End With
For i = 2 To Q
  If a(i, 7) <= Date And Date <= a(i, 8) Then
    R = 1 + R: For j = 1 To UBound(a, 2): a(R, j) = a(i, j): Next
  End If
Next
With Sheets("Sheet2")
  .Cells(1).CurrentRegion.Offset(1).Delete xlShiftUp
  If R > 0 Then .Cells(2, 1).Resize(R, UBound(a, 2)) = a
End With
End Sub 


Code Tags Added
Your post does not comply with Rule 2 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found at http://www.excelforum.com/forum-rule...rum-rules.html



(I have added them for you today. Please take a few minutes to read all Forum Rules and comply in the future.)

However, if you continue to not use code tags, you can expect to have your thread BLOCKED until you add them yourself.