VBA Code to Copy & Paste Rows based on Date data

Question

Im new to VBA, so I will geve you some context and purpose of what I hope to achieve. I am copying data from another program (no issues), I then paste it into a WorkSheet that I have coded the formate for the incoming data to nest where I want it to be (looks pretty), I paste by using a UserForm I created (still no issues). I then created another UserForm and use this to sort the data for number of days between date ranges (used VBA with formula) and if no date is present then I assign todays date (Date) all the above works great. My issue is when the user has completed the above, another UserForm pops up to ask if they want to add the overdue data to the report sheet, this is supposed to copy any rows that have todays date (Date) in Column "G" and then paste it to the report sheet row "A1" down

I would appreciate the help, I have tried a few options and searched high and wide on the net, with the following code so far it looks down column 7, currently I have 15 row items to sort through and two of them have todays date. I keep only getting the last of the two required rows with todays date to paste into the report sheet from the data sheet?

Here is the full code so far with your additional code (the first part formates the destination sheet and as you can see it ensures that destination sheet column "G" is set to format "dd/mm/yyyy":

Private Sub CommandButton1_Click()
Me.Hide
If Sheets("Masri").Visible Then
  Sheet10.Activate
  Sheet10.Cells.Clear
  Sheet10.Cells.ClearFormats
   Range("A1:I2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.499984740745262
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True
    Range("A1:I2").Select
    ActiveCell.FormulaR1C1 = _
        "Number of Days between ANSI's Aproved But not Catalogued"
    Range("A3:I3").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    Range("A3:I3").Select
    ActiveCell.FormulaR1C1 = "MASRI"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Progress"
    Selection.Font.Bold = True
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "ANSI#"
    Selection.Font.Bold = True
     Range("C4").Select
    ActiveCell.FormulaR1C1 = "Area"
    Selection.Font.Bold = True
     Range("D4").Select
    ActiveCell.FormulaR1C1 = "Supplier"
    Selection.Font.Bold = True
     Range("E4").Select
    ActiveCell.FormulaR1C1 = "Description"
    Selection.Font.Bold = True
     Range("F4").Select
    ActiveCell.FormulaR1C1 = "Approved Date"
    Selection.Font.Bold = True
     Range("G4").Select
    ActiveCell.FormulaR1C1 = "Catalogued Date"
    Selection.Font.Bold = True
     Range("H4").Select
    ActiveCell.FormulaR1C1 = "Approved By"
    Selection.Font.Bold = True
     Range("I4").Select
    ActiveCell.FormulaR1C1 = "Days Overdue"
    Selection.Font.Bold = True
    Range("A4:I4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A4:I4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("A1:I4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("G5:G40").NumberFormat = "dd/mm/yyyy"
    Columns("A:A").ColumnWidth = 18.43
    Columns("B:B").ColumnWidth = 12
    Columns("C:C").ColumnWidth = 4.43
    Columns("D:D").ColumnWidth = 34.86
    Columns("E:E").ColumnWidth = 60.71
    Columns("F:F").ColumnWidth = 15.14
    Columns("G:G").ColumnWidth = 15.14
    Columns("H:H").ColumnWidth = 20.57
    Columns("I:I").ColumnWidth = 37.86
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select
    Range("A1:I2").Select
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select
    Selection.ShapeRange.IncrementLeft -2.25
    Selection.ShapeRange.IncrementTop 0.75
    Selection.ShapeRange.IncrementLeft 2.25
    Selection.ShapeRange.IncrementTop -0.75
    Sheets("Masri").Select
    Dim FinalRow As Long, lastTargetRow As Long, lastCol As Long, tRow As Long
    Dim source As String, target As String
    Dim ThisValue As Date
     source = "Masri"        'Define your source sheet
     target = "Reports"      'Define Target sheet
     FinalRow = Sheets(source).Range("G" & Rows.Count).End(xlUp).Row
     lastCol = Sheets(source).Cells(1, Columns.Count).End(xlToLeft).Column   'If header in Row 1
     lastTargetRow = Sheets(target).Range("G" & Rows.Count).End(xlUp).Row
     tRow = lastTargetRow + 1
    For lRow = 2 To FinalRow
     ThisValue = Sheets(source).Cells(lRow, 7).Value
        If ThisValue = tempDate Then
         For lCol = 1 To lastCol  'Copy entire row
                Sheets(target).Cells(tRow, lCol).Value = Sheets(source).Cells(lRow, lCol).Value
            Next lCol
            tRow = tRow + 1         'THIS IS THE KEY TO NOT JUST COPYING THE LAST RECORD
        End If
    Next lRow
    End If
End Sub

You have an "End If" without an IF .. Also, you might want to see this Q&A that highlights How to Avoid Using Select Statements. http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros — peege, Dec 26 '14 at 10:34
Also, you really shouldn't revise your code including the answers posted. It's better if you leave your actual original code that caused you to ask the question in the question itself. Let the answers provide the fixes, and on your end on your PC you modify your code. That way, the question will make sense and one can tell what was wrong and what works. — peege, Dec 27 '14 at 02:06
You really should check into removing all the select statements that simply set values and properties. I will post one of them in the answer I provided to give you an idea of how to do that. No need to repeat the entire code. — peege, Dec 27 '14 at 04:57

score 1 · Answer 1 · edited May 23 '17 at 10:26

It looks like your problem is that you are copying the last record over top of the previous one. If you step through your code, you can confirm that theory or not.

Of course, you probably have more code above what was included in your question, judging by the lingering "End If" before the "End Sub". I'm just going to treat this as a stand alone, for the sake of Declaring the Variables, so you know what type they are.

Look at this code, which simplifies things by setting the values, instead of copying and pasting.

It loops through the source sheet, the same way your code does, using a For Loop.
Then performs a conditional test. If the match is found, a nested Loop through all the columns setting the values on the target sheet from the values on the source sheet is done.

note: the last row is being checked by column "C", (3) because your code was showing that.

Sub ConditionalCopy()

Dim FinalRow As Long, lastTargetRow As Long, lastCol As Long, tRow As Long
Dim source As String, target As String
Dim ThisValue As Date

source = "Masri"        'Define your source sheet
target = "Reports"      'Define Target sheet

FinalRow = Sheets(source).Range("C" & Rows.count).End(xlUp).row
lastCol = Sheets(source).Cells(1, Columns.count).End(xlToLeft).column   'If header in Row 1

lastTargetRow = Sheets(target).Range("C" & Rows.count).End(xlUp).row
tRow = lastTargetRow + 1

    For lRow = 2 To FinalRow

        ThisValue = Sheets(source).Cells(lRow, 7).Value

        If ThisValue = Date() Then
            For lCol = 1 To lastCol  'Copy entire row
                Sheets(target).Cells(tRow, lCol).Value = Sheets(source).Cells(lRow, lCol).Value
            Next lCol
            tRow = tRow + 1         'THIS IS THE KEY TO NOT JUST COPYING THE LAST RECORD
        End If
    Next lRow
End Sub

UPDATE: After seeing the rest of the code, I'd strongly recommend reducing any select statements.

Here is an example:

Range("F4").Select
ActiveCell.FormulaR1C1 = "Approved Date"

This is not required, and is extra work, because you don't need to select the Range to set its formula or any other property. The reason they are there is probably because of a macro being recorded, which is a good place to start. It is simulating you USING the worksheet, instead of just performing the required operations, with a small sheet, you might not notice the difference, other than the screen flicking all over, but in a large sheet, it would definitely cause problems. It's also just not a good practice.

Consider this:

Range("F4").FormulaR1C1 = "Approved Date"

Another example:

Range("A1:I2").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With

Would be revised as this:

With Range("A1:I2")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With

This link How to avoid using Select in Excel Macros provides MORE examples. You can access any property like Selection.Interior, just use the actual selection NAME instead of "Selection". To merge a range, you just say

Range("A1:I2").Merge
'or
Range("A1:I2").Unmerge

Hi peege, Thank you for the rapid response, I tryed the code but get a runtime error "Type Mismatch on this line: For lRow = 2 To FinalRow ThisValue = Sheets(source).Cells(lRow, 7).Value — Jeff, Dec 26 '14 at 22:47
I have also change the "C" to "G" this made no dfference, when I change the number in the code area "For 1Row = 2 To FinalRow" say to a 9 it does not error but still only pastes the last row data but with less column information? I will edit my code above to show the fullcode for this Macro. — Jeff, Dec 26 '14 at 22:52
The "C" is just checking for the last row. If all the columns have data in them, that shouldn't make a difference. In face, I usually use column "A" for that, but you had your code checking C. column 3.. — peege, Dec 26 '14 at 23:31
The data when copied to "Sheet Masri" comes up as cutom format, I have placed code to change the format to"dd/mm/yyyy" after initial data is pasted — Jeff, Dec 26 '14 at 23:41
I see. Keep in mind, I wrote that code before you updated your original question. So there isn't a tempDate or a variable handling the Date in your revised code. could you verify that you want "Today's" Date to be the tempDate? If so, try Date() in place of tempDate — peege, Dec 27 '14 at 02:09
Thank you peege, i will give it a go and get back to you on how it turns out — Jeff, Dec 27 '14 at 09:03
Use your Locals Window when you debug it, and step through the code. — peege, Dec 27 '14 at 09:22

VBA Code to Copy & Paste Rows based on Date data

1 Answers1