Copying Data From one worksheet to another containing todays date

[travieman90]

Attempting to copy data from sheet "2020bymachine" to A3 on activesheet. Only want to copy rows containing today's or yesterdays date in column A. The code below runs and presents no errors but does not copy anything.

Sub CopyData()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

LastRow = Cells(Cells.Rows.count, "A").End(xlUp).Row

For d = LastRow To 10 Step -1

If IsDate(Sheets("2020byMachine").Cells(d, "A")) And Sheets("2020byMachine").Cells(d, "A").Value = Date Then
count = count + 1
      If CopyRange Is Nothing Then
                Set CopyRange = Rows(d).EntireRow
        Else
                Set CopyRange = Union(CopyRange, Rows(d).EntireRow)
        End If
    End If


CopyRange.Copy

Sheets("DataSheet").Select

Range("A3").Select

ActiveSheet.Paste

End Sub

 

[Fluff]

How about

Sub CopyData()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

With Sheets("2020byMachine")
   LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
   
   For d = LastRow To 10 Step -1
   
   If .Cells(d, "A") = Date - 1 Or .Cells(d, "A").Value = Date Then
      count = count + 1
         If CopyRange Is Nothing Then
                   Set CopyRange = .Rows(d).EntireRow
           Else
                   Set CopyRange = Union(CopyRange, .Rows(d).EntireRow)
           End If
       End If
   
End With
   CopyRange.Copy Sheets("DataSheet").Range("A3")
End Sub

 

[travieman90]

How about

Sub CopyData()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

With Sheets("2020byMachine")
   LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
  
   For d = LastRow To 10 Step -1
  
   If .Cells(d, "A") = Date - 1 Or .Cells(d, "A").Value = Date Then
      count = count + 1
         If CopyRange Is Nothing Then
                   Set CopyRange = .Rows(d).EntireRow
           Else
                   Set CopyRange = Union(CopyRange, .Rows(d).EntireRow)
           End If
       End If
  
End With
   CopyRange.Copy Sheets("DataSheet").Range("A3")
End Sub

This looks promising but getting a compile error "end with without with"

 

[Fluff]

It's missing the Next d line

Sub CopyData()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

With Sheets("2020byMachine")
   LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
   
   For d = LastRow To 10 Step -1
   
   If .Cells(d, "A") = Date - 1 Or .Cells(d, "A").Value = Date Then
      count = count + 1
         If CopyRange Is Nothing Then
                   Set CopyRange = .Rows(d).EntireRow
           Else
                   Set CopyRange = Union(CopyRange, .Rows(d).EntireRow)
           End If
       End If
   Next d
End With
   CopyRange.Copy Sheets("DataSheet").Range("A3")
End Sub

 

[travieman90]

It's missing the Next d line

Sub CopyData()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

With Sheets("2020byMachine")
   LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
  
   For d = LastRow To 10 Step -1
  
   If .Cells(d, "A") = Date - 1 Or .Cells(d, "A").Value = Date Then
      count = count + 1
         If CopyRange Is Nothing Then
                   Set CopyRange = .Rows(d).EntireRow
           Else
                   Set CopyRange = Union(CopyRange, .Rows(d).EntireRow)
           End If
       End If
   Next d
End With
   CopyRange.Copy Sheets("DataSheet").Range("A3")
End Sub

Now im getting "next without for"

 

[travieman90]

Now im getting "next without for"

apologize typed next d in the wrong area

 

[travieman90]

It's missing the Next d line

Sub CopyData()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

With Sheets("2020byMachine")
   LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
  
   For d = LastRow To 10 Step -1
  
   If .Cells(d, "A") = Date - 1 Or .Cells(d, "A").Value = Date Then
      count = count + 1
         If CopyRange Is Nothing Then
                   Set CopyRange = .Rows(d).EntireRow
           Else
                   Set CopyRange = Union(CopyRange, .Rows(d).EntireRow)
           End If
       End If
   Next d
End With
   CopyRange.Copy Sheets("DataSheet").Range("A3")
End Sub

This is working fantastic. I really appreciate it. Id like to try and have it automated when i open that sheet rather than using a button to force the update if possible but regardless massive thanks to you.

 

[Fluff]

You can put it in an activate event like

Private Sub Worksheet_Activate()

Dim LastRow As Long, d As Long
Dim CopyRange As Range, count As Long

With Sheets("2020byMachine")
   LastRow = .Cells(.Rows.count, "A").End(xlUp).Row
   
   For d = LastRow To 10 Step -1
   
   If .Cells(d, "A") = Date - 1 Or .Cells(d, "A").Value = Date Then
      count = count + 1
         If CopyRange Is Nothing Then
                   Set CopyRange = .Rows(d).EntireRow
           Else
                   Set CopyRange = Union(CopyRange, .Rows(d).EntireRow)
           End If
       End If
   Next d
End With
   CopyRange.Copy Sheets("DataSheet").Range("A3")

End Sub

This code needs to go in the relevant sheet module.