VBA Macro Speed ​​Up

Question

я оценил бы некоторую помощь по следующей VBA макросов проблемы, скриншот здесь:

Я должен сравнить данные в 2 колонки - индекс & Sec_Index. В случае совпадения он должен проверить, какие значения присвоены Sec_Index, и заполнить «1» в соответствующем столбце «Значение», соответствующем индексу и «0» для других столбцов Value (надеюсь, что скриншот объясняет это лучше)

Я написал короткий макрос, который работает хорошо. Однако у меня есть огромное количество данных - оба столбца индекса содержат не менее 400000-500000 строк. Это делает мой код бесполезным, так как он будет длиться очень долго.

Есть ли способ сделать эту работу? Я читал о массивах Variant, но я не знаком с ними.

Answer 1

Вы можете сделать это с помощью формулы. Что-то вроде:

=IF(AND(LOOKUP($B2,$H$2:$H$6,$I$2:$I$6)="A",LOOKUP($B2,$H$2:$H$6,$H$2:$H$6)=B2),1,0) 

замена «B» и «C».

Answer 2

Вы можете поместить эту формулу (если Excel 2007 или выше):

=COUNTIFS($H$2:$H$5,$B2,$I$2:$I$5,"A") 

в С2 и скопировать его вдоль и поперек; просто измените «A» на «B» и «C».

Добавлено Учитывая количество строк, я бы импортировал данные в MS Access, создав запрос Crosstab, а затем скопируйте эти данные в Excel.

Answer 3

Попробуйте это, не слишком прочный, но он работает. Не знаете, насколько быстро это сравнится с тем, что у вас могло быть?

Он сделал около 60,000 строк с 25 keys примерно в 5 seconds.

Редактировать: добавлен таймер для работы.

Public Declare Function GetTickCount Lib "kernel32.dll"() As Long 
public Sub main() 
Dim t As Long 
t = GetTickCount 
    Application.ScreenUpdating = False 
    Dim Arr1(), Arr() As Double 
    Dim x, y, i, j As Double 
    Dim v As String 
    x = Cells(Rows.Count, 2).End(xlUp).Row - 2 
    y = Cells(Rows.Count, 8).End(xlUp).Row - 2 
    Range("c2", "e" & x + 2) = 0 
    ReDim Arr1(x) 
    ReDim Arr2(y) 
    i = 0 
    Do Until Cells(i + 2, 2) = "" 
     Arr1(i) = Cells(i + 2, 2) 
     i = i + 1 
    Loop 
    i = 0 
    Do Until Cells(i + 2, 8) = "" 
     Arr2(i) = Cells(i + 2, 2) 
     i = i + 1 
    Loop 
    i = 0 
    Do Until i > UBound(Arr1) 
     j = 0 
     Do Until j > UBound(Arr2) 
      If Arr1(i) = Arr2(j) Then 
       v = Cells(Arr2(j) + 1, 9) 
       Select Case v 
        Case "a" 
         Cells(i + 2, 3) = 1 
        Case "b" 
         Cells(i + 2, 4) = 1 
        Case "c" 
         Cells(i + 2, 5) = 1 
       End Select 
       Exit Do 
      End If 
      j = j + 1 
     Loop 
     i = i + 1 
    Loop 
    MsgBox GetTickCount - t, , "Milliseconds" 
End Sub