当日期重复时，如何根据日期复制和粘贴唯一数据？

Question

我正在尝试根据匹配的日期将数据从一张表复制到另一张表，到目前为止我可以做到这一点，但问题是相应日期的最新数据会覆盖同一日期的所有其他数据。

例如

我想从sheet 2 column 1 复制数据（基于column 2 中的日期）

我想将此数据粘贴到sheet 1 column 2（基于column 1 中的日期）

可以看出，只有sheet 2 column 1 中对应于相应日期的最后一个数字被粘贴到sheet 1 column 2 中的所有对应日期中。

相反，如果有两个日期，我希望将两个不同的数字（来自 sheet 2 column 1 ）粘贴到 sheet 1 column 2 中。

我的原代码如下：

Sub Macroturnip()
'
' Macroturnip Macro
'

Dim Row As Double 'row is the row variable for the destination spreadsheet
Dim i As Date
Dim x As Long 'x is the row variable for the source spreadsheet


For Row = 1 To 825


    i = Sheets("1").Cells(Row, 1)

      If i <> DateSerial(1900, 1, 0) Then
        'DateSerial(1900, 1, 0) --> this is the default for no data in the field, i.e. i want to skip these

            For x = 2 To 450


                    If Sheets("2").Cells(x, 2) = Sheets("1").Cells(Row, 1) Then
                    Sheets("2").Select
                    Cells(x, 1).Select
                    Selection.Copy
                    Sheets("1").Select
                    Cells(Row, 2).Select
                    ActiveSheet.Paste

                    End If                                                                     

            Next x            

     End If         

Next Row


End Sub

Answer 1

• 避免使用已经在代码中表示某些内容的变量名是一种很好的做法，即：Row。

• Row 数字应该是整数/长类型

• 您应该声明工作表并将其分配给变量

• VBA 中的大多数代码都可以不使用.Select 来编写，尽管有时您可能需要它，但这不是其中之一……您应该不惜一切代价避免在嵌套循环中使用它。例如：

Sheets("2").Select
Cells(x, 1).Select
Selection.Copy

可以很容易地改写成这样：

Sheets("2").Cells(x, 1).Copy

这可能需要一些更好的逻辑，但根据您的屏幕截图，它可以工作：

Sub Macroturnip()
'
' Macroturnip Macro
'

Dim wsDst As Worksheet: Set wsDst = ActiveWorkbook.Sheets("1")
Dim lRowDst As Long: lRowDst = wsDst.Cells(wsDst.Rows.Count, 1).End(xlUp).Row

Dim wsSrc As Worksheet: Set wsSrc = ActiveWorkbook.Sheets("2")
Dim lRowSrc As Long: lRowSrc = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row

Dim rngFind As Range
Dim Rs As Long, Rd As Long 'row is the row variable for the destination spreadsheet


    For Rd = 2 To lRowDst

        If wsDst.Cells(Rd, 1) <> "" Then
        'DateSerial(1900, 1, 0) --> this is the default for no data in the field, i.e. i want to skip these
            For Rs = 2 To lRowSrc
                If wsDst.Cells(Rd, 1) = wsSrc.Cells(Rs, 2) Then

                    Set rngFind = wsDst.Range("B2:B" & Rd).Find(wsSrc.Cells(Rs, 1), Lookat:=xlWhole)
                    If rngFind Is Nothing Then
                        wsDst.Cells(Rd, 2) = wsSrc.Cells(Rs, 1).Value
                        Exit For 'No need to keep checking, move on
                    End If
                    Set rngFind = Nothing
                End If
            Next Rs
        End If
    Next Rd
End Sub

PS：我假设 Sheets("2") 实际上是指名为 2 的工作表，而不是 Sheet2 或 Sheets(2) 虽然看起来相似，但不是一回事。