Excel VBAシステムコレクション配列リスト

Question

私は、コンボボックスにデータを追加するための高速なソリューションを探しています。

2つのシートで使用されるユーザーフォームがあり、アクティブシートに応じてアドレスリストが作成されます。アドレスリストは2枚のシートのいずれかから作成されます。

アクティブなシート名= SCHECK.nameの場合は、System.Collection.ArrayListを使用して、シートWIRからコンボボックスに追加された一意のソート値のリストを作成しています。

アクティブシートがS20FAの場合は、CALからリストを作成します。私はシステムコレクションを使用して、これを作成するのがはるかに速いので、私が現在アレイを作成していて、その後配列をループして、Comboboxに追加しています。

この問題は、アドレスがアレイに追加される前に、System.Collection.ArrayListで必要なチェックを実行する方法がわかりません。

これに加えて、System.Collection.ArrayListを使用して、マルチカラムコンボボックスで使用する多次元配列を作成できますか？

Dim wb As Workbook: Set wb = ThisWorkbook 
Dim myArrayList As Object 
Dim i, lastRow As Long 
Dim address() As String 
Dim number_address As Integer 
Dim cell As Range 
Dim addressList, addressItem 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 

Call wb.defineCols 
Call wb.defineSheets 

If ActiveSheet.Name = wb.SCHECK.Name Then 
    If wb.WIR.FilterMode = True Then wb.WIR.AutoFilter.ShowAllData 
    lastRow = wb.WIR.cells(Rows.count, wb.COL_Address_code).End(xlUp).Row 

    Set myArrayList = CreateObject("System.Collections.ArrayList") 
    addressList = wb.WIR.Range(wb.WIR.cells(3, wb.COL_Address_code), wb.WIR.cells(lastRow, wb.COL_Address_code)) 

    With myArrayList 
     For Each addressItem In addressList 
      If Not .Contains(addressItem) Then .add addressItem 
     Next 
     .Sort 
     If .count Then Me.address_combo.List = Application.Transpose(myArrayList.toarray()) 
    End With 
    myArrayList.Clear 
    Set myArrayList = Nothing 
ElseIf ActiveSheet.Name = wb.S20FA.Name Then 
    If wb.CAL.FilterMode = True Then wb.CAL.AutoFilter.ShowAllData 
    lastRow = wb.CAL.cells(Rows.count, "A").End(xlUp).Row 
    Set cellRange = wb.CAL.Range("A8:A" & lastRow) 
    DoEvents 
    number_address = 0 
    For Each cell In cellRange 
     number_address = number_address + 1 
     ReDim Preserve address(number_address - 1) 
      If IsError(Application.match(cell, address, False)) Then 

       '''' Test cells 

       If wb.CAL.Range("G" & cell.Row) <> "" Then 
        If IsError(wb.CAL.Range("K" & cell.Row).value) = False Then 
         If wb.CAL.Range("K" & cell.Row).value <> "" And wb.CAL.Range("K" & cell.Row).value <> 0 Then 
          If (wb.CAL.Range("Q" & cell.Row).value <> "" And wb.CAL.Range("Q" & cell.Row).value <> 0) Or _ 
           (wb.CAL.Range("W" & cell.Row).value <> "" And wb.CAL.Range("W" & cell.Row).value <> 0) Then 
           address(number_address - 1) = wb.CAL.Range("A" & cell.Row).value 
          Else 
           number_address = number_address - 1 
          End If 
         Else 
          number_address = number_address - 1 
         End If 
        End If 
       Else 
        number_address = number_address - 1 
       End If 
      Else 
       number_address = number_address - 1 
      End If 
    Next cell 

    DoEvents 
    For i = 0 To UBound(address) 
     If address(i) <> "" Then 
      address_combo.AddItem address(i) 
     End If 
    Next i 
End If 
Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

Answer 1

重複を避けたいので、重複を処理するように設計されたデータ構造を使用してください。 Scripting.Dictionaryはこの種のアプリケーションにとって優れたツールです。重複するキーを拒否するので、.keys配列にクリーンでユニークなリストがあります。

以下は、辞書データ構造を使用したコードの書き換えです。それが速度を改善するかどうか試してみてください。リストはソートされていないことに注意してください。ただし、速度が改善されてもソートが必要な場合は、あとでソートルーチンを追加することができます。

Dim wb As Workbook: Set wb = ThisWorkbook 
Dim dict As Object ' <-- changed the name to correspond to the dictionary 
Dim i, lastRow As Long 
Dim address() As String 
Dim number_address As Integer 
Dim cell As Range 
Dim addressList, addressItem 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 

Call wb.defineCols 
Call wb.defineSheets 

If ActiveSheet.Name = wb.SCHECK.Name Then 
    If wb.WIR.FilterMode Then wb.WIR.AutoFilter.ShowAllData 
    lastRow = wb.WIR.Cells(Rows.Count, wb.COL_Address_code).End(xlUp).Row 

    Set dict = CreateObject("Scripting.Dictionary") ' <-- 
    addressList = wb.WIR.Range(wb.WIR.Cells(3, wb.COL_Address_code), wb.WIR.Cells(lastRow, wb.COL_Address_code)) 

    For Each addressItem In addressList 
     If Not dict.Exists(addressItem.Value) Then dict.Add addressItem.Value, addressItem.Value 
    Next 
    If dict.Count > 0 Then Me.address_combo.List = Application.Transpose(dict.toarray()) 
ElseIf ActiveSheet.Name = wb.S20FA.Name Then 
    If wb.CAL.FilterMode = True Then wb.CAL.AutoFilter.ShowAllData 
    lastRow = wb.CAL.Cells(Rows.Count, "A").End(xlUp).Row 
    Set cellRange = wb.CAL.Range("A8:A" & lastRow) 
    DoEvents 
    number_address = 0 
    For Each cell In cellRange 
     If Not dict.Exists(cell.Value) And _ 
      wb.CAL.Range("G" & cell.Row) <> "" And _ 
      Not IsError(wb.CAL.Range("K" & cell.Row).Value) And _ 
      wb.CAL.Range("K" & cell.Row).Value <> "" And wb.CAL.Range("K" & cell.Row).Value <> 0 And _ 
      ((wb.CAL.Range("Q" & cell.Row).Value <> "" And wb.CAL.Range("Q" & cell.Row).Value <> 0) Or _ 
      (wb.CAL.Range("W" & cell.Row).Value <> "" And wb.CAL.Range("W" & cell.Row).Value <> 0)) Then 

      dict.Add cell.Value, cell.Value 
     End If 
    Next cell 
    DoEvents 
    address_combo.List = dict.Items 
End If 
Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

Answer 2

これは、私がA.S.H提案の助けを借りて解決した解決策です。

私は元のSystem.Collection.ArrayListをそのまま使用しており、両方の場合に使用しています。

シート上をループして2番目の要件をチェックするのではなく、すべての範囲をメモリにコピーしてチェックします。

この方法では、以前は数秒ではなく、完了までに0.03秒のスピードを達成していません。

あなたが間違いや改善を感じることができれば、私にコメントを残してください。私はすべての方法で新しいソリューションを試してみたいと思います。

Dim wb As Workbook: Set wb = ThisWorkbook 
Dim myArrayList As Object: Set myArrayList = CreateObject("System.Collections.ArrayList") 
Dim i, lastRow As Long 
Dim address() As String 
Dim number_address As Integer 
Dim cell As Range 
Dim addressList, addressItem 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 

Call wb.defineCols 
Call wb.defineSheets 

If ActiveSheet.Name = wb.PCHECK.Name Then 
    If wb.WIR.FilterMode = True Then wb.WIR.AutoFilter.ShowAllData 
    lastRow = wb.WIR.cells(Rows.count, wb.COL_Address_code).End(xlUp).Row 
    addressList = wb.WIR.Range(wb.WIR.cells(3, wb.COL_Address_code), wb.WIR.cells(lastRow, wb.COL_Address_code)) 
    With myArrayList 
     For Each addressItem In addressList 
      If Not .Contains(addressItem) Then .add addressItem 
     Next 
     .Sort 
     If .count > 0 Then Me.ComboBox1.List = Application.Transpose(myArrayList.toarray()) 
    End With 
ElseIf ActiveSheet.Name = wb.S20FA.Name Then 
    If wb.CAL.FilterMode = True Then wb.CAL.AutoFilter.ShowAllData 
    lastRow = wb.CAL.cells(Rows.count, "A").End(xlUp).Row 
    addressList = wb.CAL.Range("A8:W" & lastRow).value 
    With myArrayList 
     For i = LBound(addressList) To UBound(addressList, 1) 
      If Not .Contains(addressList(i, 1)) Then 
       If addressList(i, 7) <> "" Then 
        If Not IsError(addressList(i, 11)) And addressList(i, 11) <> "" And addressList(i, 11) <> 0 Then 
         If (addressList(i, 18) <> "" And addressList(i, 18) <> 0) Then 
          .add addressList(i, 1) 
         End If 
        End If 
       End If 
      End If 
     Next i 
     .Sort 
     If .count > 0 Then Me.ComboBox1.List = Application.Transpose(myArrayList.toarray()) 
    End With 
End If 

myArrayList.Clear 
Set myArrayList = Nothing