VBA tableau dynamique duplication de certaines valeurs par erreur

Question

Je tiens à préface en disant que je n'ai aucune idée de quoi que ce soit pourquoi mon code fait ce qu'il fait. J'espère vraiment qu'un des gourous de VBA ici peut aider. Aussi, ceci est mon premier post alors j'ai fait de mon mieux pour suivre les règles, mais si j'ai fait quelque chose de mal, veuillez le signaler. J'ai un sous qui itére à travers une colonne de données et crée un tableau. Il appelle une fonction qui vérifie si la valeur particulière est déjà dans le tableau. Si ce n'est pas le cas, le tableau est redimensionné, la valeur est insérée et le processus recommence, jusqu'à ce que la fin de la liste soit atteinte. Je me retrouve avec un tableau totalisant 41 valeurs, mais 4 d'entre elles ont été dupliquées deux fois, donc il n'y a que 37 valeurs uniques dans le tableau.

Je ne peux pas pour la vie de moi comprendre ce qui distingue ces valeurs ou pourquoi ils sont en cours de duplication. La liste totale est longue de plus de 700 valeurs donc j'ai pensé que je devrais voir d'autres valeurs dupliquées, mais je ne le suis pas.

Voici le code pour la sous qui crée le tableau:

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 

Et voici le code qui vérifie si la valeur checkString est dans le tableau:

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 

---

Toute aide sera la bienvenue. J'ai été capable de trouver des réponses à toutes mes questions précédemment (ou au moins débugger et voir un problème évident) mais celui-ci m'a bloqué. J'espère que quelqu'un peut comprendre ce qui se passe.

---

[EDIT] Voici le code où le sous est appelé:

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 et blFrmClose sont définis dans les déclarations générales.

Answer 1

Aucun des (sauvage) devine jusqu'à ce que la cause du problème en double vous êtes avoir sont même proches. C'est en fait causé par un bug dans votre code.

Dans votre fonction IsInArray, vous terminez l'index de la boucle de la baie à la mauvaise valeur. For i = 1 To UBound(arr, 2) doit être For i = 1 To UBound(arr, 2) - LBound(arr, 2) + 1. Lorsque votre index termine un court, cela signifie que la chaîne de comparaison n'est jamais vérifiée par rapport au dernier élément de tableau et que, par conséquent, la seconde de toutes les valeurs identiques consécutives sera copiée en tant que doublon. Toujours utiliser les deux LBound et UBound dans les paramètres d'index pour éviter cela et les types de bugs similaires. Cependant, ce correctif est redondant car la fonction peut être réécrite pour éviter une boucle dans son ensemble. J'ai aussi ajouté quelques autres améliorations:

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 

---

Voici mon avis sur une solution dictionnaire:

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 

Et voici comment appeler la fonction:

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 

Notez en particulier la méthode sans boucle utilisée pour copier le contenu du dictionnaire dans la feuille de calcul.

Answer 2

Problèmes

Vous recherchez des chaînes dans un tableau de variantes. Les données peuvent être une chaîne ou un nombre, ce qui vous donne des doublons. Je suggère de changer votre fonction Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean à Function IsInArray(stringToBeFound As Variant, arr() As Variant) As Boolean

Il y a quelques variables qui doivent être déclarées. Voir ci-dessous.

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

Je devine que vous obtenez des doublons parce j et arrProductNumber est sont des variables globales. Vous devriez vous débarrasser des Globals en passant la feuille de travail à une fonction qui retournera votre tableau.

Vous pouvez simplement ajouter les références de cellule à un Scripting.Dictionary

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

et récupérer plus tard la référence par sa valeur clé

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

J'utilise ici une ArrayList (je aurais pu utiliser un Scripting.Dictionnaire) pour vérifier les doublons et agir en tant que contre Redim un tableau multidimensionnel.

---

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

par les recommandations de @RonRosenfield et @braX, j'ai essayé un Scripting.Dictionary et est venu avec cette réponse. Il crée et vérifie les valeurs, contrairement à ma méthode précédente qui utilisait un sub pour créer et une fonction à vérifier.

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 

J'ai eu quelques difficultés à obtenir des valeurs de ce dictionnaire, mais a constaté que cela a fonctionné:

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