基于日期数据复制和粘贴行的 VBA 代码

VBA Code to Copy & Paste Rows based on Date data

提问by Jeff

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

我是 VBA 的新手，所以我会给你一些我希望实现的背景和目的。我正在从另一个程序复制数据（没有问题），然后将其粘贴到工作表中，我已将传入数据的格式编码到我想要的位置（看起来很漂亮），我使用我创建的用户窗体粘贴（仍然没有问题）。然后我创建了另一个用户窗体并使用它来对日期范围之间的天数数据进行排序（使用带有公式的 VBA），如果没有日期，那么我分配今天的日期（日期）以上所有工作都很好。我的问题是，当用户完成上述操作后，会弹出另一个用户窗体询问他们是否要将过期数据添加到报告表中，这应该复制列“G”中具有今天日期（日期）的任何行和然后将其粘贴到报告表行“A1”向下

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?

我很感激您的帮助，我尝试了一些选项并在网上进行了广泛搜索，到目前为止，使用以下代码向下查看第 7 列，目前我有 15 个行项目要排序，其中两个有今天的日期。我一直只获取具有今天日期的两个必需行中的最后一行，以便从数据表粘贴到报告表中？

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":

这是到目前为止的完整代码以及您的附加代码（第一部分格式化目标工作表，如您所见，它确保目标工作表列“G”设置为格式“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

回答by peege

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.

当然，根据“End Sub”之前挥之不去的“End If”判断，您可能在问题中包含的代码之上有更多代码。为了声明变量，我只是将其视为一个独立的部分，以便您知道它们是什么类型。

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.

它使用 For 循环循环遍历源表，就像您的代码所做的那样。
然后执行条件测试。如果找到匹配项，则通过所有列的嵌套循环从源工作表上的值设置目标工作表上的值。

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

注意：最后一行正在由列“C”（3）检查，因为您的代码显示了这一点。

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 Macrosprovides 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

此链接如何避免在 Excel 宏中使用 Select提供了更多示例。您可以访问任何属性，如 Selection.Interior，只需使用实际选择名称而不是“选择”。要合并范围，您只需说

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