VBAの動的配列エラーの一部を複製する

Question

私は何も考えていないと言ってこれを覚えておきたい。なぜ自分のしていることをやっているのですか？私は本当にここにいるVBA指導者の一人が助けてくれることを願っています。また、これは私の最初の投稿ですので、私はルールに従うように最善を尽くしましたが、何か間違ったことがあった場合はそれを指摘してください。

---

私は、データの列を反復して配列を作成するサブを持っています。特定の値がすでに配列に含まれているかどうかを調べる関数を呼び出します。そうでない場合は、配列の寸法が変更され、値が挿入され、プロセスが再び開始され、リストの終わりに達するまで続きます。私は41個の値を合計した配列で終わるが、そのうちの4個は2回複製されているので、配列には37個の一意の値しかない。

私の人生では、これらの値を何が離れているのか、なぜそれらが重複しているのか理解できません。私は他の値が重複しているのを見なければならないと思ったが、私はそうではない。ここで

は、配列を作成し、サブのためのコードです：

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 
    Dim bDimen As Byte, i As Long 

    On Error Resume Next 
    If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2 
    On Error GoTo 0 

    Select Case bDimen 
    Case 1 
     On Error Resume Next 
     IsInArray = Application.Match(stringToBeFound, arr, 0) 
     On Error GoTo 0 
    Case 2 
     For i = 1 To UBound(arr, 2) 
      On Error Resume Next 
      IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0) 
      On Error GoTo 0 
      If IsInArray = True Then Exit For 
     Next 
    End Select 
End Function 

---

：

Sub ProductNumberArray(strWrkShtName As String, strFindColumn As String, blAsGrp As Boolean, iStart As Integer) 
    Dim i As Integer 
    Dim lastRow As Integer 
    Dim iFindColumn As Integer 
    Dim checkString As String 

    With wbCurrent.Worksheets(strWrkShtName) 
     iFindColumn = .UsedRange.Find(strFindColumn, .Range("A1"), xlValues, xlWhole, xlByColumns).Column 
     lastRow = .Cells(Rows.Count, iFindColumn).End(xlUp).row 
     For i = iStart To lastRow 
      checkString = .Cells(i, iFindColumn).Value 
      If IsInArray(checkString, arrProductNumber) = False Then 
       If blAsGrp = False Then 
        ReDim Preserve arrProductNumber(0 To j) 
        arrProductNumber(j) = checkString 
        j = j + 1 
       Else 
        ReDim Preserve arrProductNumber(1, 0 To j) 
        arrProductNumber(0, j) = .Cells(i, iFindColumn - 1).Value 
        arrProductNumber(1, j) = checkString 
        j = j + 1 
       End If 
      End If 
     Next i 
    End With 
End Sub 

そして、ここではcheckString配列に値があるかどうかをチェックするコードです

何か助けを歓迎します。私は以前のすべての質問に対する答えを見つけ出すことができました（または少なくともデバッグして明らかな問題を見ることができました）が、これは私を困惑させました。私は誰かが何が起こっているのか理解できることを願っています。

---

ここ[EDIT]サブが呼び出されているコードである。

Sub UpdatePSI()  
    Set wbCurrent = Application.ActiveWorkbook 
    Set wsCurrent = wbCurrent.ActiveSheet 

    frmWorkbookSelect.Show 

    If blFrmClose = True Then 'if the user closes the selection form, the sub is exited 
     blFrmClose = False 
     Exit Sub 
    End If 

    Set wsSelect = wbSelect.Sheets(1) 

    Call ProductNumberArray("Forecast", "Item", True, 3) 

wbCurrent、wsCurrent、及びblFrmCloseは、一般宣言で規定されています。

Answer 1

なしに、これまであなたがしている重複した問題を引き起こしているものについての推測持っていることも近い。実際には、コード内のバグが原因です。

IsInArray関数では、配列ループインデックスが間違った値で終了します。 For i = 1 To UBound(arr, 2)はFor i = 1 To UBound(arr, 2) - LBound(arr, 2) + 1である必要があります。索引が短くなったら、比較文字列が最後の配列項目と照合されることはなく、その結果、連続する同一の値の2番目の値が複製としてコピーされます。このようなタイプのバグを回避するには、インデックスパラメータに常にLBoundとUBoundの両方を使用してください。

ただし、この修正は、ループを完全に回避するために関数を書き換えることができるため、冗長です。ここで

---

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 
    Dim bDimen As Long 
    Dim i As Long 

    On Error Resume Next 
    bDimen = 2 
    If IsError(UBound(arr, 2)) Then bDimen = bDimen - 1 
    If IsError(UBound(arr, 1)) Then bDimen = bDimen - 1 
    On Error GoTo 0 

    Select Case bDimen 
    Case 0: 
    ' Uninitialized array - return false 
    Case 1: 
     On Error Resume Next 
     IsInArray = Application.Match(stringToBeFound, arr, 0) 
     On Error GoTo 0 
    Case 2: 
     On Error Resume Next 
     IsInArray = Application.Match(stringToBeFound, Application.Index(arr, 2), 0) 
     On Error GoTo 0 
    Case Else 
     ' Err.Raise vbObjectError + 666, Description:="Never gets here error." 
    End Select 
End Function 

辞書ソリューションが私の感想です：

Public Function ProductNumberDict _ 
       (_ 
          ByVal TheWorksheet As Worksheet, _ 
          ByVal Header As String, _ 
          ByVal AsGroup As Boolean, _ 
          ByVal Start As Long _ 
       ) _ 
     As Scripting.Dictionary 

    Set ProductNumberDict = New Scripting.Dictionary 
    With TheWorksheet.Rows(1).Cells(WorksheetFunction.Match(Header, TheWorksheet.Rows(1), 0)).EntireColumn 
    Dim rngData As Range 
    Set rngData = TheWorksheet.Range(.Cells(Start), .Cells(Rows.Count).End(xlUp)) 
    End With 
    Dim rngCell As Range 
    For Each rngCell In rngData 
    With rngCell 
     If Not ProductNumberDict.Exists(.Value2) Then 
     ProductNumberDict.Add .Value2, IIf(AsGroup, .Offset(, -1).Value2, vbNullString) 
     End If 
    End With 
    Next rngCell 
End Function 

そして、ここで関数を呼び出す方法です：

Sub UpdatePSI() 

    Dim wkstForecast As Worksheet 
    Set wkstForecast = ActiveWorkbook.Worksheets("Forecast") 

' ... 

    Dim dictProductNumbers As Scripting.Dictionary 
    Set dictProductNumbers = ProductNumberDict(wkstForecast, "Item", False, 7) 
    Set dictProductNumbers = ProductNumberDict(wkstForecast, "Item", True, 3) 

    Dim iRowStart As Long: iRowStart = 2 
    Dim iFirstCol As Long: iFirstCol = 5 
    With wkstForecast.Cells(iRowStart, iFirstCol).Resize(RowSize:=dictProductNumbers.Count) 
    .Offset(ColumnOffset:=1).Value = WorksheetFunction.Transpose(dictProductNumbers.Keys) 
    .Offset(ColumnOffset:=2).Value = WorksheetFunction.Transpose(dictProductNumbers.Items) 
    End With 

' ... 

End Sub 

を私はまた、いくつかの他の拡張機能を追加しました

特に、ワークシートに辞書の内容をコピーするために使用される非ループメソッドに注意してください。

Answer 2

問題

バリアント配列内の文字列をチェックしています。データは文字列または数字である可能性があります。したがって、重複を与えます。あなたの関数を変更することをお勧めします。Function IsInArray(stringToBeFound As String, arr As Variant) As BooleanをFunction IsInArray(stringToBeFound As Variant, arr() As Variant) As Boolean

宣言する必要がある変数がいくつかあります。下記参照。

Sub ProductNumberArray(strWrkShtName As String, strFindColumn As String, blAsGrp As Boolean, iStart As Integer) 
Dim i As long, j as long 'just use long for i. integers are silently converted to long anyway. leaving j undeclared makes it variant. 
Dim lastRow As Integer 
Dim iFindColumn As Integer 
Dim checkString As Variant ' changed to variant 
Dim arrProductNumber() as Variant ' delcare a dynamic array 

ReDim arrProductNumber(0 To 0) ' making it an array 

j = 0 'giving somewhere to start 

With wbCurrent.Worksheets(strWrkShtName) 
    iFindColumn = .UsedRange.Find(strFindColumn, .Range("A1"), xlValues, xlWhole, xlByColumns).Column 
    lastRow = .Cells(Rows.Count, iFindColumn).End(xlUp).row 
    For i = iStart To lastRow 
     checkString = .Cells(i, iFindColumn).Value 
     If IsInArray(checkString, arrProductNumber) = False Then 
      If blAsGrp = False Then 
       ReDim Preserve arrProductNumber(0 To j) 
       arrProductNumber(j) = checkString 
       j = j + 1 
      Else 
       ReDim Preserve arrProductNumber(1, 0 To j) 
       arrProductNumber(0, j) = .Cells(i, iFindColumn - 1).Value 
       arrProductNumber(1, j) = checkString 
       j = j + 1 
      End If 
     End If 
    Next i 
End With 
End Sub 

Answer 3

私はjとarrProductNumberはグローバル変数ですですので、あなたが重複を取得していることを推測しています。配列を返す関数にワークシートを渡すことによって、グローバルを取り除く必要があります。あなたは、単にScripting.Dictionary

If not dic.Exists(Cell.Value) then dic.Add Cell.Value, Cell 

にセル参照を追加し、後でそれによって参照を取得することができ

は、ここで私はArrayListのを使用して（私が使用している可能性が

ProductOffset = dic("PID798YD").Offset(0,-1) 

キー値ですスクリプティングディクショナリ）を使用して重複をチェックし、多次元配列をRedimへのカウンタとして機能させます。 @RonRosenfieldと@braXの勧告パー

---

Sub TestgetProductData() 
    Dim results As Variant 
    results = getProductData(ActiveSheet, "Column 5", True, 3) 
    Stop 
    results = getProductData(ActiveSheet, "Column 5", False, 3) 
    Stop 
End Sub 

Function getProductData(ws As Worksheet, ColumnHeader As String, blAsGrp As Boolean, iStart As Integer) As Variant 
    Dim results As Variant 
    Dim cell As Range, Source As Range 
    Dim list As Object 
    Set list = CreateObject("System.Collections.ArrayList") 

    With ws.UsedRange 
     Set Source = .Find(ColumnHeader, .Range("A1"), xlValues, xlWhole, xlByColumns) 
     If Not Source Is Nothing Then 
      Set Source = Intersect(.Cells, Source.EntireColumn) 
      Set Source = Intersect(.Cells, Source.Offset(iStart)) 
      For Each cell In Source 
       If Not list.Contains(cell.Value) Then 

        If blAsGrp Then 
         If list.Count = 0 Then ReDim results(0 To 1, 0 To 0) 

         ReDim Preserve results(0 To 1, 0 To list.Count) 
         results(0, list.Count) = cell.Offset.Value 
         results(1, list.Count) = cell.Value 
        End If 
        list.Add cell.Value 
       End If 
      Next 
     End If 
    End With 
    If blAsGrp Then 
     getProductData = results 
    Else 
     getProductData = list.ToArray 
    End If 
End Function 

Answer 4

、私はScripting.Dictionaryを試してみましたが、この答えを思い付きました。これは、作成するサブとチェックする関数を使用していた以前のメソッドとは異なり、値を作成してチェックします。

Sub ProductNumberDictionary(strWrkShtName As String, strFindCol As String, blAsGrp As Boolean, iStart As Integer) 
    Dim i As Integer 
    Dim iLastRow As Integer 
    Dim iFindCol As Integer 
    Dim strCheck As String 

    Set dictProductNumber = CreateObject("Scripting.Dictionary") 

    With wbCurrent.Worksheets(strWrkShtName) 
     iFindCol = .UsedRange.Find(strFindCol, .Cells(1, 1), xlValues, xlWhole, xlByColumns).Column 
     iLastRow = .Cells(Rows.Count, iFindCol).End(xlUp).row 
     For i = iStart To iLastRow 
      strCheck = .Cells(i, iFindCol).Value 
      If dictProductNumber.exists(strCheck) = False Then 
       If blAsGrp = False Then 
        dictProductNumber.Add Key:=strCheck 
       Else 
        dictProductNumber.Add Key:=strCheck, Item:=.Cells(i, iFindCol - 1).Value 
       End If 
      End If 
     Next 
    End With 
End Sub 

私はこの辞書から値を取得していくつかの困難があったが、これは働いていないことがわかった：（野生）の

Dim o as Variant 
    i = 0 
    For Each o In dictProductNumber.Keys 
     .Cells(iRowStart + i, iFirstCol + 1) = o 'returns the value of the key 
     .Cells(iRowStart + i, iFirstCol + 2) = dictProductNumber(o) 'returns the item stored with the key 
     i = i + 1 
    Next