Suppression d'éléments dans un tableau si Element est une valeur certaine VBA
J'ai un tableau global, prLst() qui peut être de longueur variable. Il prend des nombres sous forme de chaînes "1" à Ubound(prLst). Cependant, lorsque l'utilisateur entre "0", je souhaite supprimer cet élément de la liste. J'ai le code suivant écrit pour effectuer ceci:
count2 = 0
eachHdr = 1
totHead = UBound(prLst)
Do
If prLst(eachHdr) = "0" Then
prLst(eachHdr).Delete
count2 = count2 + 1
End If
keepTrack = totHead - count2
'MsgBox "prLst = " & prLst(eachHdr)
eachHdr = eachHdr + 1
Loop Until eachHdr > keepTrack
Cela ne fonctionne pas. Comment supprimer efficacement des éléments du tableau prLst si l'élément est "0"?
NOTE: Ceci fait partie d’un programme plus vaste, dont la description est disponible ici: Tri des groupes de rangées Excel VBA Macro
Un tableau est une structure d'une certaine taille. Vous pouvez utiliser des tableaux dynamiques dans vba que vous pouvez réduire ou agrandir à l’aide de ReDim, mais vous ne pouvez pas supprimer d’éléments au milieu. Votre exemple ne dit pas clairement comment fonctionne votre tableau ni comment vous déterminez la position de l'index (eachHdr), mais vous avez en gros 3 options.
(A) Ecrivez une fonction 'delete' personnalisée pour votre tableau comme (non testée)
Public Sub DeleteElementAt(Byval index As Integer, Byref prLst as Variant)
Dim i As Integer
' Move all element back one position
For i = index + 1 To UBound(prLst)
prLst(i - 1) = prLst(i)
Next
' Shrink the array by one, removing the last one
ReDim Preserve prLst(Len(prLst) - 1)
End Sub
(B) Définissez simplement une valeur «factice» comme valeur au lieu de supprimer réellement l'élément
If prLst(eachHdr) = "0" Then
prLst(eachHdr) = "n/a"
End If
(C) Arrêtez d'utiliser un tableau et changez-le en VBA.Collection. Une collection est une structure de paires clé/valeur (unique) dans laquelle vous pouvez librement ajouter ou supprimer des éléments.
Dim prLst As New Collection
Sub DelEle(Ary, SameTypeTemp, Index As Integer) '<<<<<<<<< pass only not fixed sized array (i don't know how to declare same type temp array in proceder)
Dim I As Integer, II As Integer
II = -1
If Index < LBound(Ary) And Index > UBound(Ary) Then MsgBox "Error.........."
For I = 0 To UBound(Ary)
If I <> Index Then
II = II + 1
ReDim Preserve SameTypeTemp(II)
SameTypeTemp(II) = Ary(I)
End If
Next I
ReDim Ary(UBound(SameTypeTemp))
Ary = SameTypeTemp
Erase SameTypeTemp
End Sub
Sub Test()
Dim a() As Integer, b() As Integer
ReDim a(3)
Debug.Print "InputData:"
For I = 0 To UBound(a)
a(I) = I
Debug.Print " " & a(I)
Next
DelEle a, b, 1
Debug.Print "Result:"
For I = 0 To UBound(a)
Debug.Print " " & a(I)
Next
End Sub
Je suis assez nouveau dans vba et Excel - cela ne dure que depuis environ 3 mois - Je pensais partager ma méthode de déduplication de tableaux ici, car ce message semble pertinent:
Ce code fait partie d'une application plus grande qui analyse les données de canal - Les tubes sont répertoriés dans une feuille avec un numéro au format xxxx.1, xxxx.2, aaaa.1, aaaa.2 ..... C’est la raison pour laquelle toutes les manipulations de chaînes existent… .. fondamentalement, il ne collecte le numéro de tuyau qu’une seule fois, et non la partie .2 ou .1.
With wbPreviousSummary.Sheets(1)
' here, we will write the edited pipe numbers to a collection - then pass the collection to an array
Dim PipeDict As New Dictionary
Dim TempArray As Variant
TempArray = .Range(.Cells(3, 2), .Cells(3, 2).End(xlDown)).Value
For ele = LBound(TempArray, 1) To UBound(TempArray, 1)
If Not PipeDict.Exists(Left(TempArray(ele, 1), Len(TempArray(ele, 1) - 2))) Then
PipeDict.Add Key:=Left(TempArray(ele, 1), Len(TempArray(ele, 1) - 2)), _
Item:=Left(TempArray(ele, 1), Len(TempArray(ele, 1) - 2))
End If
Next ele
TempArray = PipeDict.Items
For ele = LBound(TempArray) To UBound(TempArray)
MsgBox TempArray(ele)
Next ele
End With
wbPreviousSummary.Close SaveChanges:=False
Set wbPreviousSummary = Nothing 'done early so we dont have the information loaded in memory
Utilisation d’un tas de boîtes de message pour le débogage d’une atmosphère, je suis sûr que vous le modifierez en fonction de votre propre travail.
J'espère que les gens trouveront cela utile, Cordialement Joe
Je sais que c'est vieux, mais voici la solution que j'ai trouvée quand je n'ai pas aimé celles que j'ai trouvées.
-Passez sur le tableau (Variant) en ajoutant chaque élément et un diviseur à une chaîne, sauf si cela correspond à celui que vous souhaitez supprimer - Puis divisez la chaîne sur le diviseur.
tmpString=""
For Each arrElem in GlobalArray
If CStr(arrElem) = "removeThis" Then
GoTo SkipElem
Else
tmpString =tmpString & ":-:" & CStr(arrElem)
End If
SkipElem:
Next
GlobalArray = Split(tmpString, ":-:")
De toute évidence, l'utilisation de chaînes crée certaines limitations, comme devoir être sûr des informations déjà dans le tableau, et tel quel, ce code rend le premier élément de tableau vide, mais il fait ce dont j'ai besoin et avec un peu plus de travail plus polyvalent.
voici un exemple de code utilisant la fonction CopyMemory pour effectuer le travail.
C'est soi-disant "beaucoup plus rapide" (en fonction de la taille et du type du tableau ...).
je ne suis pas l'auteur, mais je l'ai testé:
Sub RemoveArrayElement_Str(ByRef AryVar() As String, ByVal RemoveWhich As Long)
'// The size of the array elements
'// In the case of string arrays, they are
'// simply 32 bit pointers to BSTR's.
Dim byteLen As Byte
'// String pointers are 4 bytes
byteLen = 4
'// The copymemory operation is not necessary unless
'// we are working with an array element that is not
'// at the end of the array
If RemoveWhich < UBound(AryVar) Then
'// Copy the block of string pointers starting at
' the position after the
'// removed item back one spot.
CopyMemory ByVal VarPtr(AryVar(RemoveWhich)), ByVal _
VarPtr(AryVar(RemoveWhich + 1)), (byteLen) * _
(UBound(AryVar) - RemoveWhich)
End If
'// If we are removing the last array element
'// just deinitialize the array
'// otherwise chop the array down by one.
If UBound(AryVar) = LBound(AryVar) Then
Erase AryVar
Else
ReDim Preserve AryVar(LBound(AryVar) To UBound(AryVar) - 1)
End If
End Sub
Suppression d'éléments dans un tableau si Element est une valeur certaine VBA
supprimer des éléments dans un tableau avec certaines conditions, vous pouvez coder comme ceci
For i = LBound(ArrValue, 2) To UBound(ArrValue, 2)
If [Certain condition] Then
ArrValue(1, i) = "-----------------------"
End If
Next i
StrTransfer = Replace(Replace(Replace(join(Application.Index(ArrValue(), 1, 0), ","), ",-----------------------,", ",", , , vbBinaryCompare), "-----------------------,", "", , , vbBinaryCompare), ",-----------------------", "", , , vbBinaryCompare)
ResultArray = join( Strtransfer, ",")
Je manipule souvent 1D-Array avec Join/Split Mais si vous devez supprimer certaines valeurs dans Multi Dimension, je vous suggère de changer ces tableaux en 1D-Array comme ceci
strTransfer = Replace(Replace(Replace(Replace(Names.Add("A", MultiDimensionArray), Chr(34), ""), "={", ""), "}", ""), ";", ",")
'somecode to edit Array like 1st code on top of this comment
'then loop through this strTransfer to get right value in right dimension
'with split function.
C'est simple. Je l'ai fait de la manière suivante pour obtenir une chaîne avec des valeurs uniques (à partir de deux colonnes d'une feuille de sortie):
Dim startpoint, endpoint, ArrCount As Integer
Dim SentToArr() As String
'created by running the first part (check for new entries)
startpoint = ThisWorkbook.Sheets("temp").Range("A1").Value
'set counter on 0
Arrcount = 0
'last filled row in BG
endpoint = ThisWorkbook.Sheets("BG").Range("G1047854").End(xlUp).Row
'create arr with all data - this could be any data you want!
With ThisWorkbook.Sheets("BG")
For i = startpoint To endpoint
ArrCount = ArrCount + 1
ReDim Preserve SentToArr(1 To ArrCount)
SentToArr(ArrCount) = .Range("A" & i).Value
'get prep
ArrCount = ArrCount + 1
ReDim Preserve SentToArr(1 To ArrCount)
SentToArr(ArrCount) = .Range("B" & i).Value
Next i
End With
'iterate the arr and get a key (l) in each iteration
For l = LBound(SentToArr) To UBound(SentToArr)
Key = SentToArr(l)
'iterate one more time and compare the first key (l) with key (k)
For k = LBound(SentToArr) To UBound(SentToArr)
'if key = the new key from the second iteration and the position is different fill it as empty
If Key = SentToArr(k) And Not k = l Then
SentToArr(k) = ""
End If
Next k
Next l
'iterate through all 'unique-made' values, if the value of the pos is
'empty, skip - you could also create a new array by using the following after the IF below - !! dont forget to reset [ArrCount] as well:
'ArrCount = ArrCount + 1
'ReDim Preserve SentToArr(1 To ArrCount)
'SentToArr(ArrCount) = SentToArr(h)
For h = LBound(SentToArr) To UBound(SentToArr)
If SentToArr(h) = "" Then GoTo skipArrayPart
GetEmailArray = GetEmailArray & "; " & SentToArr(h)
skipArrayPart:
Next h
'some clean up
If Left(GetEmailArray, 2) = "; " Then
GetEmailArray = Right(GetEmailArray, Len(GetEmailArray) - 2)
End If
'show us the money
MsgBox GetEmailArray
Lors de la création de la matrice, pourquoi ne pas simplement ignorer les 0 et gagner du temps pour vous inquiéter plus tard? Comme mentionné ci-dessus, les tableaux ne conviennent pas à la suppression.