Question

我想比较2个时间值，如果它们匹配，则在那时粘贴温度值，如果在特定时间点缺少一个测量值，则指定0。此代码当前可用于1000个值（耗时少于1分钟），但是对于10,000个值来说，耗时超过一个小时。如何减少循环时间？

Sub findMatching()
Dim CurrentLine As Integer, CurrentLine2 As Integer, CurrentLine3 As Integer
Dim MaxRows As Integer, MaxRows2 As Integer

MaxRows = 1000
MaxRows2 = 1000
CurrentLine = 1
For CurrentLine = 1 To MaxRows '-- Loop in A column (read data)
    For CurrentLine2 = 1 To MaxRows2 '-- Loop in D column (compare data)
      If Sheets(1).Cells(CurrentLine, 1) = Sheets(1).Cells(CurrentLine2,4) Then
      '-- copying matching data
    Sheets(1).Cells(CurrentLine, 2) = Sheets(1).Cells(CurrentLine2, 5)
    CurrentLine = CurrentLine + 1
    ElseIf Sheets(1).Cells(CurrentLine, 1) <> Sheets(1).Cells(CurrentLine2,4) Then
      Sheets(1).Cells(CurrentLine, 2) = 0
    End If
   Next CurrentLine2
 Next CurrentLine
End Sub

Answer 1

下面的代码取决于您能否访问Scripting.Dictionary对象。我使用后期绑定，因此您无需添加参考。

您说Range.Resize杀死了您。不太清楚为什么会这样，但是我在下面的代码中再次使用它。如果您有性能问题，请告诉我。

Option Explicit

Private Sub findFirstMatching()

    ' Declared two constants because OP had done it that way in their post.
    ' Depending on use case, could get rid of second and just use the one
    ' But having two allows you to change one without the other.
    Const READ_ROW_COUNT As Long = 10000 ' Used for columns A, B
    Const COMPARISON_ROW_COUNT As Long = 10000 ' Used for columns D, E

    ' Change sheet name below to wherever the data is. I assume Sheet1 '
    With ThisWorkbook.Worksheets("Sheet1")

        Dim columnA() As Variant
        columnA = .Range("A1").Resize(READ_ROW_COUNT, 1).Value2

        Dim columnD() As Variant
        columnD = .Range("D1").Resize(COMPARISON_ROW_COUNT, 1).Value2

        Dim columnE() As Variant
        columnE = .Range("E1").Resize(COMPARISON_ROW_COUNT, 1).Value2

        Dim dict As Object
        Set dict = CreateObject("Scripting.Dictionary")

        Dim rowIndex As Long

        ' Fill dictionary (array values as dictionary's keys, row numbers as dictionary's corresponding values)
        ' If there are duplicates in column D, the dictionary will only contain/return the row number of the FIRST instance/match
        For rowIndex = LBound(columnD, 1) To UBound(columnD, 1)
            If Not dict.Exists(columnD(rowIndex, 1)) Then
                dict.Add columnD(rowIndex, 1), rowIndex
            End If
        Next rowIndex

        Dim outputArray() As Variant
        ReDim outputArray(1 To READ_ROW_COUNT, 1 To 1)
        Dim rowIndexOfFirstMatch As Long

        ' Now loop through column A's values and check if it exists in dict
        For rowIndex = LBound(columnA, 1) To UBound(columnA, 1)
            If dict.Exists(columnA(rowIndex, 1)) Then
                rowIndexOfFirstMatch = dict.Item(columnA(rowIndex, 1))
                outputArray(rowIndex, 1) = columnE(rowIndexOfFirstMatch, 1)
            Else
                outputArray(rowIndex, 1) = "#N/A" ' Change to zero if needed.
            End If
        Next rowIndex

        .Range("B1").Resize(READ_ROW_COUNT, 1) = outputArray

    End With
End Sub

我测试了我最终生成的一些伪数据上的代码，对我来说，代码似乎应该按照您所描述的进行操作（对于A列中的每个值，输出中的B列都包含{{1 }}或E列中的值（如果找到匹配项）。如果仍然没有，请告诉我为什么/出了什么问题。

Answer 2

如果使用Excel for PC作为Office应用程序可以与JET / ACE SQL Engine（Windows .DLL文件）接口，请考虑使用SQL。本质上，您需要跨列的条件计算，可以使用IIF处理（与ANSI SQL的CASE相对）。对于这种基于集合的操作，可以非常快速地运行10,000条记录。此解决方案无需循环。

以下假设：

您在装有ODBC / OLEDB驱动程序的PC上运行Excel 2007 +。
数据从A1开始，并带有命名列。范围和字段可以根据需要进行更改。在SQL中调整列和工作表名称，保留方括号[]和$）
存在一个名为“ RESULTS”的空表。

SQL （嵌入VBA中）

SELECT t.*, IIF(t.[TimeValue1] = t.[TimeValue2], t.[TemperatureValue], 0) As NewColumn
FROM [SheetName$] t

VBA

Sub RunSQL()
On Error GoTo ErrHandle
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer, fld As Object

    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    ' ODBC AND OLEDB CONNECTIONS
    '    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
    '                      & "DBQ=" & ThisWorkbook.FullName & ";"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='" & ThisWorkbook.FullName & "';" _
                       & "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"

    strSQL = "SELECT t.*, IIF(t.timeValue1 = t.timeValue2, t.Temperaturevalue, 0) As NewColumn" _
             & " FROM [SheetName$] t;"

    ' OPEN CONNECTION
    conn.Open strConnection
    rst.Open strSQL, conn

    With ThisWorkbook.Worksheets("RESULTS")
       ' COLUMNS
       For i = 1 To rst.Fields.Count
          .Cells(1, i) = rst.Fields(i - 1).Name
       Next i 

       ' DATA
      .Range("A2").CopyFromRecordset rst
    End With

    rst.Close: conn.Close
    MsgBox "Successfully ran SQL query!", vbInformation

ExitHandle:
    Set rst = Nothing: Set conn = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
    Resume ExitHandle
End Sub

vba高效循环可比较并复制和粘贴超过10,000个值

2 个答案: