Эффективный цикл vba для сравнения, копирования и вставки более 10 000 значений - PullRequest
Новая
       49

Эффективный цикл vba для сравнения, копирования и вставки более 10 000 значений

0 голосов
/ 11 октября 2018

Я хотел бы сравнить 2 значения времени и, если они совпадают, затем вставить значение температуры в это время, если в определенный момент времени отсутствует одно измерение, а затем присвоить 0. Этот код в настоящее время работает для 1000 значений(занимает менее 1 минуты), однако для 10000 значений это занимает более часа.Как сократить время цикла? 

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

Ответы [ 2 ]

0 голосов
/ 12 октября 2018

Рассмотрите SQL, если используете Excel для ПК, поскольку приложение Office может взаимодействовать с JET / ACE SQL Engine (файлы Windows .DLL).По сути, вам нужен условный расчет по столбцам, который можно обработать с помощью IIF (аналог ANSI SQL's CASE).Для этой операции на основе набора 10 000 записей очень быстро запускаются.Для этого решения циклы не требуются.

Ниже предполагается, что:

  1. Вы запускаете Excel 2007+ на ПК с установленными драйверами ODBC / OLEDB.
  2. Данные начинаются с A1 с именованными столбцами.Диапазоны и поля могут быть изменены по мере необходимости.Настройте столбцы и имя листа в SQL, оставив скобки [] и $)
  3. Существует пустой лист с именем "РЕЗУЛЬТАТЫ".

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
0 голосов
/ 11 октября 2018

Код ниже полагается на возможность доступа к объекту 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 в моих выходных данных содержит либо #N/A, либо значение в столбце E, если совпадение было найдено).Если этого не произойдет, дайте мне знать, почему / что не так.

...