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

我有两个硬件设备logging数据，我需要同步每个logging的时间，使数据匹配在两个设备上。

时间是接近的，但并不总是相同的：我每0.2秒logging数据，但有时一个设备会有一个稍大或稍小的差距。

目前，我从L单位和R单位导入excel，然后将时间整数精确到0.1秒。 这样，时间要么完全匹配，要么closures0.1秒（这足够接近我的目的）。

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

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

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

匹配值时使用集合。 这里我使用一个Scripting.Dictionary。

 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

从技术上讲，这种types的post属于CodeReview.SE 。

但我不知道如何投票迁移到那里，所以这里应该是一个更小的代码……它在执行时间方面的比较在空中稍微高一点，但它也应该更快。

replace这个：

 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