Excel VBA外观以更有效的方式匹配相似的数字

Question

我有两个记录数据的硬件设备，我需要同步每个设备记录的时间，以便两个设备上的数据匹配。

时间很接近，但并不总是相同的：我每0.2秒记录一次数据，但有时一台设备的间隙会略大或小。

目前，我将时间从L单位和R单位导入excel，然后将时间舍入到最接近的0.1秒。这样，时间要么完全匹配，要么相差 0.1 秒（这对于我的目的来说已经足够接近了）。

我编写了一个 VBA 脚本（如下）将 R 单元中的数据粘贴到 L 单元中。它工作正常，但对于我正在处理的数据量（25,000+ 行）来说太慢了

我希望有人可以检查代码并建议一种更快的方法来做同样的事情。

Sub NewTimesComparisonLoop()
Application.ScreenUpdating = False
Dim LBottomRow As Long
Dim RBottomRow As Long
Dim LSheet As Worksheet
Dim Rsheet As Worksheet
Dim LStartCell As Range
Dim RStartcell As Range
Dim Li As Long
Dim Ri As Long
Set LSheet = Worksheets("Sheet1")
Set Rsheet = Worksheets("Sheet2")
'find the last row of times in column b
Set LStartCell = Range("B1")
LBottomRow = LSheet.Cells(LSheet.Rows.Count, LStartCell.Column).End(xlUp).row
Set RStartcell = Range("B1")
RBottomRow = Rsheet.Cells(Rsheet.Rows.Count, RStartcell.Column).End(xlUp).row
'get data set of sheet1, column B
'LSheet.Range(StartCell, LSheet.Cells(BottomRow, 2)).Select
'loop through each R value, comparing against a loop of L values
'if they match, or if R is under by 0.1 sec, copy the R values into columns j through P
For Ri = 1 To RBottomRow
    For Li = 1 To LBottomRow
        If Sheets("Sheet2").Cells(Ri, 2).Value = Sheets("Sheet1").Cells(Li, 2).Value Then
            Sheets("Sheet1").Cells(Li, 10).Value = Sheets("Sheet2").Cells(Ri, 3).Value
            Sheets("Sheet1").Cells(Li, 11).Value = Sheets("Sheet2").Cells(Ri, 4).Value
            Sheets("Sheet1").Cells(Li, 12).Value = Sheets("Sheet2").Cells(Ri, 5).Value
            Sheets("Sheet1").Cells(Li, 13).Value = Sheets("Sheet2").Cells(Ri, 6).Value
            Sheets("Sheet1").Cells(Li, 14).Value = Sheets("Sheet2").Cells(Ri, 7).Value
            Sheets("Sheet1").Cells(Li, 15).Value = Sheets("Sheet2").Cells(Ri, 8).Value
            Sheets("Sheet1").Cells(Li, 16).Value = Sheets("Sheet2").Cells(Ri, 9).Value
        ElseIf Sheets("Sheet2").Cells(Ri, 2).Value + 0.1 = Sheets("Sheet1").Cells(Li, 2).Value Then
            Sheets("Sheet1").Cells(Li, 10).Value = Sheets("Sheet2").Cells(Ri, 3).Value
            Sheets("Sheet1").Cells(Li, 11).Value = Sheets("Sheet2").Cells(Ri, 4).Value
            Sheets("Sheet1").Cells(Li, 12).Value = Sheets("Sheet2").Cells(Ri, 5).Value
            Sheets("Sheet1").Cells(Li, 13).Value = Sheets("Sheet2").Cells(Ri, 6).Value
            Sheets("Sheet1").Cells(Li, 14).Value = Sheets("Sheet2").Cells(Ri, 7).Value
            Sheets("Sheet1").Cells(Li, 15).Value = Sheets("Sheet2").Cells(Ri, 8).Value
            Sheets("Sheet1").Cells(Li, 16).Value = Sheets("Sheet2").Cells(Ri, 9).Value
        End If
    Next Li
Next Ri
Application.ScreenUpdating = True
End Sub

Answer 1

匹配值时使用集合。 这里我使用脚本字典。

Sub NewTimesComparisonLoop()
    Application.ScreenUpdating = False
    Dim cell As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet2")
        For Each cell In .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
            If Not dict.Exists(cell.Value) Then dict.Add cell.Value, cell.Offset(0, 1).Resize(1, 7).Value
        Next
    End With
    With Sheets("Sheet1")
        For Each cell In .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
            If dict.Exists(cell.Value) Then
                cell.Offset(0, 1).Resize(1, 7).Value = dict(cell.Value)
            ElseIf dict.Exists(cell.Value + 0.1) Then
                cell.Offset(0, 1).Resize(1, 7).Value = dict(cell.Value + 0.1)
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

从技术上讲，这种类型的帖子属于 CodeReview.SE。

但是我不知道如何投票将其迁移到那里，所以这里应该是一个明显较小的代码......它在执行时间方面的比较有点悬而未决，但也应该更快。

替换此内容：

For Ri = 1 To RBottomRow
    For Li = 1 To LBottomRow
        If Sheets("Sheet2").Cells(Ri, 2).Value = Sheets("Sheet1").Cells(Li, 2).Value Then
            Sheets("Sheet1").Cells(Li, 10).Value = Sheets("Sheet2").Cells(Ri, 3).Value
            Sheets("Sheet1").Cells(Li, 11).Value = Sheets("Sheet2").Cells(Ri, 4).Value
            Sheets("Sheet1").Cells(Li, 12).Value = Sheets("Sheet2").Cells(Ri, 5).Value
            Sheets("Sheet1").Cells(Li, 13).Value = Sheets("Sheet2").Cells(Ri, 6).Value
            Sheets("Sheet1").Cells(Li, 14).Value = Sheets("Sheet2").Cells(Ri, 7).Value
            Sheets("Sheet1").Cells(Li, 15).Value = Sheets("Sheet2").Cells(Ri, 8).Value
            Sheets("Sheet1").Cells(Li, 16).Value = Sheets("Sheet2").Cells(Ri, 9).Value
        ElseIf Sheets("Sheet2").Cells(Ri, 2).Value + 0.1 = Sheets("Sheet1").Cells(Li, 2).Value Then
            Sheets("Sheet1").Cells(Li, 10).Value = Sheets("Sheet2").Cells(Ri, 3).Value
            Sheets("Sheet1").Cells(Li, 11).Value = Sheets("Sheet2").Cells(Ri, 4).Value
            Sheets("Sheet1").Cells(Li, 12).Value = Sheets("Sheet2").Cells(Ri, 5).Value
            Sheets("Sheet1").Cells(Li, 13).Value = Sheets("Sheet2").Cells(Ri, 6).Value
            Sheets("Sheet1").Cells(Li, 14).Value = Sheets("Sheet2").Cells(Ri, 7).Value
            Sheets("Sheet1").Cells(Li, 15).Value = Sheets("Sheet2").Cells(Ri, 8).Value
            Sheets("Sheet1").Cells(Li, 16).Value = Sheets("Sheet2").Cells(Ri, 9).Value
        End If
    Next Li
Next Ri

有了这个：

For Ri = 1 To RBottomRow
    For Li = 1 To LBottomRow
        If ("Sheet2").Cells(Ri, 2).Value - Sheets("Sheet1").Cells(Li, 2).Value <= 0.1 Then _ 
          Sheets("Sheet1").Range("J" & Li & ":P" & Li).Value = _
          ("Sheet2").Range("C" & Ri & ":I" & Ri).Value
    Next Li
Next Ri