VBA Copy All Rows With Today's Date in a Cell

[riskyrowboat]

Hello All,

I am new to VBA and looking for some help. I am trying to write code to loop through column B in Sheet1, identify all cells that have today's date as a value, then copy the entire row based on this value.

Below is what I have so far, but it seems to be only copying the bottom row (the last one with today's date). Am I looping in the wrong direction?

Dim DCell As Range

For Each DCell In Range("B:B")
If DCell.Value = Date Then
DCell.EntireRow.Copy
End If
Next DCell

Thanks in advance.

[Trebor76]

Hi riskyrowboat,

Welcome to the forum!!

I have a couple of initial questions:

• Where do you want the code to copy the cell contents once they've been found, and
• What's the maximum number of rows (roughly) we're dealing with

Robert

[riskyrowboat]

Hi Trebor,

Thanks for the welcome.

I am going to copy it to another workbook. We're talking about 10 to 30 rows maximum.

Here's what I have so far, though it's not working.

Sub AddNewTrades()

Dim TradeManager As Workbook
Dim NewTrades As Workbook
Dim DCell As Range


Application.ScreenUpdating = False

Workbooks.Open Filename:="J:\TradeInterpolator.xlsm"

Set NewTrades = Workbooks("New Trade Spreadsheet")
Set TradeManager = Workbooks("TradeInterpolator")

TradeManager.Activate
Rows("2:1000").ClearContents

NewTrades.Activate
With Sheet1
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With

For Each DCell In Range("B:B")
If DCell.Value = Date Then
DCell.EntireRow.Copy
End If
Next DCell

TradeManager.Activate
Sheet1.Activate
Range("A2").PasteSpecial xlPasteValues

End Sub

[Trebor76]

Can't really test this without re-creating the wheel, but I think the syntax is correct (or very close):


Option Explicit
Sub AddNewTrades()
Dim TradeManager As Workbook
Dim NewTrades As Workbook
Dim DCell As Range

Application.ScreenUpdating = False

Workbooks.Open Filename:="J:\TradeInterpolator.xlsm"

Set NewTrades = Workbooks("New Trade Spreadsheet")
Set TradeManager = Workbooks("TradeInterpolator")

TradeManager.Activate
Rows("2:1000").ClearContents

NewTrades.Activate
With Sheet1
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With

For Each DCell In Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
If CDate(DCell.Value) = Date Then
DCell.EntireRow.Copy _
Destination:=Workbooks(TradeManager.Name).Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)(2)
End If
Next DCell

TradeManager.Activate
Sheet1.Activate
Range("A2").PasteSpecial xlPasteValues

Application.ScreenUpdating = True

End Sub

HTH

Robert

PS - you should always wrap any code you post with the appropriate tags as I've done

[riskyrowboat]

Hi Robert,

Thank you for the help.

I tried using your code, but it gave me a type mismatch error on the below line. Any suggestions?

If CDate(DCell.Value) = Date Then

I know this is an annoying one to troubleshoot without setting up the exact files.....much appreciated

RR

[Trebor76]

It's becuase there's a text entry in a cell that the CDate (VBA) function can't work with.

Try replacing that block of code with this:


For Each DCell In Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
If IsDate(DCell.Value) = True Then
If CDate(DCell.Value) = Date Then
DCell.EntireRow.Copy _
Destination:=Workbooks(TradeManager.Name).Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)(2)
End If
End If
Next DCell

Robert

[riskyrowboat]

Thanks, that fixed that problem. But now it is taking issue with the below line, saying that the subscript is out of range:

DCell.EntireRow.Copy _
Destination:=Workbooks(TradeManager.Name).Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)(2)

[Trebor76]

I assumed that the data will be pasted into the next available row in Col. A of "Sheet1" within the "Trademanager" workbook - try changing the tab name (and Col if needed) to where the data should be copied into and try again.

[riskyrowboat]

Thanks Robert....it works now. I very much appreciate your help!

RR

[Trebor76]

Thanks for the feedback and I'm glad VBAX was able to provide you with a suitable solution :)