Словарь Альтернатива для поиска совпадающих значений между 2 массивами - PullRequest
Новая
       2

Словарь Альтернатива для поиска совпадающих значений между 2 массивами

0 голосов
/ 25 января 2019

Я долго искал способ сопоставить 2 массива на основе нескольких условий, а затем записать значение в этот массив после выполнения этих условий. Я сделал это, НО это далеко, чтобы замедлить и вылетает Excel. Я пытаюсь использовать объект словаря для достижения этой цели, чтобы ускорить процедуру сопоставления, но у меня ничего не получается.

Проще говоря, в приведенной ниже процедуре я проверяю, выполняются ли определенные условия. Если это так, то напишите OutPut_Array, чтобы я мог сопоставить значение, найденное в ShtInPut_Array позже. 

Sub Cat_Payments_Test2()

  Dim InPut_Array As Variant, ShtInPut_Array As Variant
  Dim OutPut_Array()
  Dim i As Long
  Dim x As Long, y As Long

    With Application
      .ScreenUpdating = False
      .EnableEvents = False
    End With

    'Would have used Value 2, but I want to preseve the Date formating
    InPut_Array = Sheet19.Range("A1:NWH26").Value
    ShtInPut_Array = Sheet14.Range("A2:Z50667").Value

        ReDim OutPut_Array(1 To 3, LBound(InPut_Array, 2) To UBound(InPut_Array, 2))

       'The Part is super fast
        'On Error Resume Next
        For i = LBound(InPut_Array, 2) To UBound(InPut_Array, 2)
            'Case 1: InPut_Array(14, i) is on the first day of the month
            If InPut_Array(15, i) = (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) Then
                    'Looking for payments On First Day of CurrMonth
                   If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
                   And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") _
                   Or InStr(InPut_Array(16, i), "*Req Adj*")) And Not (InStr(InPut_Array(16, i), "Prior")) Then

                            InPut_Array(25, i) = "Payment"
                            InPut_Array(26, i) = "Repair Order"

                   ElseIf Len(InPut_Array(20, i)) = 7 And IsNumeric(InPut_Array(20, i)) And (InStr(InPut_Array(15, i), "Prior") _
                   Or InStr(InPut_Array(15, i), "Current")) And InPut_Array(19, i) < 0 Then

                            InPut_Array(24, i) = "RO/Accr Adj."
                            InPut_Array(25, i) = "Reversing Entry"
                   End If

            'Case 2 : InPut_Array(14, i) is between the first day of the month and the last day of the month
            ElseIf (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) < InPut_Array(14, i) < WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                    'Looking for payments MidMonth (i.e. after the FirstDay_CurrMon _
                    but before LastDayCurrMont
                    If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) _
                    Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) And Not (InStr(InPut_Array(16, i), "Prior")) Then

                            InPut_Array(25, i) = "Payment"
                            InPut_Array(26, i) = "Repair Order"

                            'Write PO Num
                            OutPut_Array(1, i) = InPut_Array(21, i)
                            'Print the first day of the current month's date
                            OutPut_Array(2, i) = DatePart("d", (CDate(InPut_Array(15, i)) - Day(CDate(InPut_Array(15, i))) + 1))
                            'Print the Amount
                            OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                    End If

            'Case 3.1 and 3.2
            ElseIf InPut_Array(15, i) = WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                    If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
                    And (InStr(InPut_Array(16, i), "Prior") Or InStr(InPut_Array(16, i), "Current")) _
                    And InPut_Array(20, i) < 0 Then

                            InPut_Array(25, i) = "RO/Accr Adj."
                            InPut_Array(26, i) = "Repair Order"

                            'Write PO Num
                            OutPut_Array(1, i) = InPut_Array(21, i)
                            'Print the first day of the current month's date
                            OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                            'Print Amount
                            OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                    'If criteria met for payment on the last day of the Current Month _
                    then do the same as payments for MidMonth
                    ElseIf Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) _
                    Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
                    And Not (InStr(InPut_Array(16, i), "Prior")) Then

                            InPut_Array(25, i) = "Payment"
                            InPut_Array(26, i) = "Repair Order"

                            'PO Num
                            OutPut_Array(1, i) = InPut_Array(21, i)
                            'Print the first day of the current month's date
                            OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                            'Print Amount
                            OutPut_Array(3, i) = Abs(InPut_Array(20, i))
                    End If
            End If
        Next i

            'This matching procedure is what is crashing excel
           For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)
            For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
               If ShtInPut_Array(x, 21) = OutPut_Array(1, y) _
               And DatePart("d", ShtInPut_Array(x, 15)) = OutPut_Array(2, y) _
               And Abs(ShtInPut_Array(x, 20)) = OutPut_Array(3, y) Then

               ShtInPut_Array(x, 25) = "RO/Accr Adj."
               ShtInPut_Array(x, 26) = "Repair Order"
                Exit For
                End If
            Next y
        Next x

        Sheet17.Range("A2").Resize(UBound(ShtInPut_Array, 1), UBound(ShtInPut_Array, 2)) = ShtInPut_Array

           Application.EnableEvents = True

End Sub

Я пытался выяснить это в течение хорошей недели или дольше, и если бы я сказал вам, сколько у меня сейчас тестовых модулей от скимминга SO и буквально везде, вы бы подумали, что я сошел с ума. Мои мысли, где адаптировать идею @TimWilliams из этого поста, но мне нужны индексы массивов, а не адреса. На данный момент мне нужно немного ТАКОГО гения. Спасибо всем, у кого есть идеи или ответы!

Редактировать: Ниже приведен полный рабочий код с реализацией словаря @TimWilliams (большое спасибо Тиму). Единственное отличие состоит в том, что я выбираю раннее связывание вместо позднее связывание для Dictionary объекта. Для этого необходимо сослаться на Microsoft Scripting Runtime в редакторе Visual Basic ( VBE ), выбрав Инструменты> Ссылки> Microsoft Scripting Runtime . Раннее связывание добавляет немного больше скорости, потому что вы информируете Excel об объекте раньше времени выполнения. Он также включает функцию intellisense VBE, которая удобна для быстрого доступа к свойствам и методам объекта. 

 Sub Cat_Payments_Test2()

 Dim InPut_Array As Variant, ShtInPut_Array As Variant
 Dim OutPut_Array()
 Dim i As Long
 Dim x As Long, y As Long
 Dim Dict As Dictionary 'Early Binding
 Dim k As Variant

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With

  'Would have used Value 2, but I want to preseve the Date formating
  InPut_Array = Sheet19.Range("A1:NWH26").Value
  ShtInPut_Array = Sheet14.Range("A2:Z50667").Value

    ReDim OutPut_Array(1 To 3, LBound(InPut_Array, 2) To UBound(InPut_Array, 2))

    For i = LBound(InPut_Array, 2) To UBound(InPut_Array, 2)
        'Case 1: GL/Date (i.e.InPut_Array(14, i)) is on the first day of the month
        If InPut_Array(15, i) = (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) Then
                'Looking for payments On First Day of CurrMonth
               If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
               And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) Or _
               InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
               And Not (InStr(InPut_Array(16, i), "Prior")) Then

                        InPut_Array(25, i) = "Payment"
                        InPut_Array(26, i) = "Repair Order"

               ElseIf Len(InPut_Array(20, i)) = 7 And IsNumeric(InPut_Array(20, i)) _
               And (InStr(InPut_Array(15, i), "Prior") Or InStr(InPut_Array(15, i), "Current")) _
               And InPut_Array(19, i) < 0 Then

                        InPut_Array(24, i) = "RO/Accr Adj."
                        InPut_Array(25, i) = "Reversing Entry"
               End If

        'Case 2 : GL/Date is between the first day of the month and the last day of the month
        ElseIf (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) < InPut_Array(15, i) < WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                'Looking for payments MidMonth (i.e. after the FirstDay_CurrMon _
                but before LastDayCurrMont
                If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 _
                And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
                And Not (InStr(InPut_Array(16, i), "Prior")) Then

                        InPut_Array(25, i) = "Payment"
                        InPut_Array(26, i) = "Repair Order"

                        'Write PO Num
                        OutPut_Array(1, i) = InPut_Array(21, i)
                        'Print the first day of the current month's date
                        OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                        'Print the Amount
                        OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                End If

        'Case 3.1 and 3.2: If GL/Date is on the last of the month
        ElseIf InPut_Array(15, i) = WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
                And (InStr(InPut_Array(16, i), "Prior") Or InStr(InPut_Array(16, i), "Current")) _
                And InPut_Array(20, i) < 0 Then

                        InPut_Array(25, i) = "RO/Accr Adj."
                        InPut_Array(26, i) = "Repair Order"

                        'Write PO Num
                        OutPut_Array(1, i) = InPut_Array(21, i)
                        'Print the first day of the current month's date
                        OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                        'Print Amount
                        OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                'If criteria met for payment on the last day of the Current Month _
                then do the same as payments for MidMonth
                ElseIf Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 _
                And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
                And Not (InStr(InPut_Array(16, i), "Prior")) Then

                        InPut_Array(25, i) = "Payment"
                        InPut_Array(26, i) = "Repair Order"

                        'PO Num
                        OutPut_Array(1, i) = InPut_Array(21, i)
                        'Print the first day of the current month's date
                        OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                        'Print Amount
                        OutPut_Array(3, i) = Abs(InPut_Array(20, i))
                End If
        End If
    Next i

    '***************************
    'Dictionary Implementation 
    Set Dict = New Dictionary 'Early Binding

    'populate dictionary with composite keys from output array
    For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
        k = Join(Array(OutPut_Array(1, y), _
                       OutPut_Array(2, y), _
                       OutPut_Array(3, y)), "~~")
        Dict(k) = True
    Next y

    'compare...
    For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)

        k = Join(Array(ShtInPut_Array(x, 21), _
                       DatePart("d", ShtInPut_Array(x, 15)), _
                       Abs(ShtInPut_Array(x, 20))), "~~")

        If Dict.Exists(k) Then
            ShtInPut_Array(x, 25) = "RO/Accr Adj."
            ShtInPut_Array(x, 26) = "Repair Order"
        End If

    Next x
    '***************************

        Sheet17.Range("A2").Resize(UBound(ShtInPut_Array, 1), UBound(ShtInPut_Array, 2)) = ShtInPut_Array

    'Note for those who were curious as _ 
     to why I did't Set Application.ScreenUpdating = True _ 
     It's b/c Excel does so automatically, so not doing so _ 
     pro-grammatically saves a bit of speed  
    Application.EnableEvents = True

End Sub

Ответы [ 2 ]

0 голосов
/ 26 января 2019

У вас есть замечательная причина перейти на объектно-ориентированный подход - пришло время управлять сложностью кода, создавая цепочки ответственности, упрощения и разделения на короткие независимые функции.Объект декомпозиции задачи может выглядеть так: 

Public Sub Code_All_2_Units_Tests (Optional ByVal msg As Variant)
    Var_Public_Clear _
            to_ClipBoard (_
            Array_walk (_
            Array_Comments_delete (_
            Split_by_vbrclf (_
            in_Quotes_remove (_
            Underscore_replace (_
            Paste_from_clipboard (_
            Settings)))))))
End sub

Не стремитесь сразу к скорости кода и его качеству.Сначала качество кода, затем скорость.У объектно-ориентированного подхода есть много других преимуществ.

0 голосов
/ 25 января 2019

Примерно так: 

Dim dict, k
Set dict = CreateObject("scripting.dictionary")

'populate dictionary with composite keys from output array
For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
    k = Join(Array(OutPut_Array(1, y), _
                   OutPut_Array(2, y), _
                   OutPut_Array(3, y)), "~~")
    dict(k) = True
Next y

'compare...
For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)

    k = Join(Array(ShtInPut_Array(x, 21), _
                   DatePart("d", ShtInPut_Array(x, 15)), _
                   Abs(ShtInPut_Array(x, 20))), "~~") 

    If dict.exists(k) Then
        ShtInPut_Array(x, 25) = "RO/Accr Adj."
        ShtInPut_Array(x, 26) = "Repair Order"
    End If

Next x
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...