Problème VBA
Résolu
dubolg
-
dubolg -
dubolg -
Bonjour,
Je suis à la recherche d'une idée pour résoudre un problème simple (sauf pour moi)
j'ai sous excel une suite de numéro :
10
10
12
14
16
16
16
16
18
20
...
J'aimerais dans un premier temps pouvoir garder tous les nombres en double et supprimer ceux qui son seul. Et dans un deuxième temps,en repartant de la même liste faire l'inverse, c'est à dire garder les nombres seul et supprimer ceux qui sont en double.
J'essaye depuis un certain temps de trouver une solution mais je me retrouve avec des if sans dessus dessous alors je vous demande si quelqu'un connait une méthode simple et efficace.
Merci
Je suis à la recherche d'une idée pour résoudre un problème simple (sauf pour moi)
j'ai sous excel une suite de numéro :
10
10
12
14
16
16
16
16
18
20
...
J'aimerais dans un premier temps pouvoir garder tous les nombres en double et supprimer ceux qui son seul. Et dans un deuxième temps,en repartant de la même liste faire l'inverse, c'est à dire garder les nombres seul et supprimer ceux qui sont en double.
J'essaye depuis un certain temps de trouver une solution mais je me retrouve avec des if sans dessus dessous alors je vous demande si quelqu'un connait une méthode simple et efficace.
Merci
6 réponses
Salut !
As-tu essayé avec la fonction Count If ?
Voilà un code qui pourrait résoudre ton premier problème si tu as une liste de 20 nombres située dans la colonne A par exemple :
Sub Test()
For i = 1 To 20
Cells(1, 2).Value = WorksheetFunction.CountIf(Columns(1), Cells(i, 1).Value)
If Cells(1, 2).Value = 1 Then
Cells(1, 2).Value = ""
End If
Next i
End Sub
Pour ton deuxième problème, tu n'as qu'à remplacer le "=1" par ">1" !
En espérant t'avoir aidé !
As-tu essayé avec la fonction Count If ?
Voilà un code qui pourrait résoudre ton premier problème si tu as une liste de 20 nombres située dans la colonne A par exemple :
Sub Test()
For i = 1 To 20
Cells(1, 2).Value = WorksheetFunction.CountIf(Columns(1), Cells(i, 1).Value)
If Cells(1, 2).Value = 1 Then
Cells(1, 2).Value = ""
End If
Next i
End Sub
Pour ton deuxième problème, tu n'as qu'à remplacer le "=1" par ">1" !
En espérant t'avoir aidé !
bonjour,
si j'ai bien compris ton problème, tu ne veux que garder les nombres qui apparaissent deux fois car:
_ tu ne gardes que ceux qui apparaissent deux fois
_ puis tu ne gardes que si ils sont seuls
Pour que la macro fonctionne, il faut que ta liste soit triée!!!
et en plus ca va inscrire une formule en colonne 2, j'espère qu'il n'y a pas de données.
Sub x()
i = 1
Do While i <= 60000 'va regarder ta liste de la première ligne à la 60000
Cells(i, 2).Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R" & i + 1 & "C[-1]:R60000C[-1], rc[-1])"
If Cells(i, 2) <> 1 Then
Range(Rows(i), Rows(i + Cells(i, 2))).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
Rows(i).Select
Selection.Delete Shift:=xlUp
End If
i = i + 1
Loop
End Sub
si j'ai bien compris ton problème, tu ne veux que garder les nombres qui apparaissent deux fois car:
_ tu ne gardes que ceux qui apparaissent deux fois
_ puis tu ne gardes que si ils sont seuls
Pour que la macro fonctionne, il faut que ta liste soit triée!!!
et en plus ca va inscrire une formule en colonne 2, j'espère qu'il n'y a pas de données.
Sub x()
i = 1
Do While i <= 60000 'va regarder ta liste de la première ligne à la 60000
Cells(i, 2).Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R" & i + 1 & "C[-1]:R60000C[-1], rc[-1])"
If Cells(i, 2) <> 1 Then
Range(Rows(i), Rows(i + Cells(i, 2))).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
Rows(i).Select
Selection.Delete Shift:=xlUp
End If
i = i + 1
Loop
End Sub
Non, n'est pas conforme a mon besoin.
Liste de départ :
15
10
10
10
8
20
20
15
Au final j'essaie d'avoir dans mon 1er cas (supprimer les uni-nombre):
10
10
10
20
20
Au final j'essaie d'avoir dans mon 2ème cas (supprimer les multi-nombre):
15
8
15
Je cherche également une solution de mon côté pour résoudre ce casse tête
Liste de départ :
15
10
10
10
8
20
20
15
Au final j'essaie d'avoir dans mon 1er cas (supprimer les uni-nombre):
10
10
10
20
20
Au final j'essaie d'avoir dans mon 2ème cas (supprimer les multi-nombre):
15
8
15
Je cherche également une solution de mon côté pour résoudre ce casse tête
Bonjour,
éventuellement tu peux le faire sans vba :
Insérer une colonne B et une ligne 1 pour les titres de colonne.
- en B2 : =ET(NB.SI(A:A;A2)>1;EQUIV(A2;A:A;0)=LIGNE()) à recopier vers le bas
- mettre un filtre automatique en ligne 1 et sélectionner les FAUX en colonne B
- sélectionner la 1ère ligne, shift+clic sur la dernière, clic-droit et 'supprimer la ligne'
Il ne reste plus que le 1er exemplaire des doublons.
http://www.cijoint.fr/cjlink.php?file=cj201108/cijEyxEtEC.xls
eric
éventuellement tu peux le faire sans vba :
Insérer une colonne B et une ligne 1 pour les titres de colonne.
- en B2 : =ET(NB.SI(A:A;A2)>1;EQUIV(A2;A:A;0)=LIGNE()) à recopier vers le bas
- mettre un filtre automatique en ligne 1 et sélectionner les FAUX en colonne B
- sélectionner la 1ère ligne, shift+clic sur la dernière, clic-droit et 'supprimer la ligne'
Il ne reste plus que le 1er exemplaire des doublons.
http://www.cijoint.fr/cjlink.php?file=cj201108/cijEyxEtEC.xls
eric
bonjour,
Maintenant que j'ai mieux compris ton besoin, essaie cette petite macro
en colonne 2, tu auras ta liste des multinombres
en colonn3, tu auras ta liste des nombres seuls.
Sub x()
i = 1
a=2
c=2
Do While i <= 60000 'va regarder ta liste de la première ligne à la 60000
'si ton nombre est égal au nombre de la ligne suivante
if cells(i,1) = cells(i+1,1) then
cells(a,2) = cells(i,1)
b=1
do while cells(i,1) = cells(i+b,1)
b=b+1
loop
i=i+b
a=a+1
else
cells(c,3) = cells(i,1)
end if
Loop
End Sub
Maintenant que j'ai mieux compris ton besoin, essaie cette petite macro
en colonne 2, tu auras ta liste des multinombres
en colonn3, tu auras ta liste des nombres seuls.
Sub x()
i = 1
a=2
c=2
Do While i <= 60000 'va regarder ta liste de la première ligne à la 60000
'si ton nombre est égal au nombre de la ligne suivante
if cells(i,1) = cells(i+1,1) then
cells(a,2) = cells(i,1)
b=1
do while cells(i,1) = cells(i+b,1)
b=b+1
loop
i=i+b
a=a+1
else
cells(c,3) = cells(i,1)
end if
Loop
End Sub
j'ai fait une petite bourde dans ma macro, copie celle là :
Sub x()
i = 1
a=2
c=2
Do While i <= 60000 'va regarder ta liste de la première ligne à la 60000
'si ton nombre est égal au nombre de la ligne suivante
if cells(i,1) = cells(i+1,1) then
cells(a,2) = cells(i,1)
b=1
do while cells(i,1) = cells(i+b,1)
b=b+1
loop
i=i+b
a=a+1
else
cells(c,3) = cells(i,1)
c=c+1
i=i+1
end if
Loop
End Sub
Sub x()
i = 1
a=2
c=2
Do While i <= 60000 'va regarder ta liste de la première ligne à la 60000
'si ton nombre est égal au nombre de la ligne suivante
if cells(i,1) = cells(i+1,1) then
cells(a,2) = cells(i,1)
b=1
do while cells(i,1) = cells(i+b,1)
b=b+1
loop
i=i+b
a=a+1
else
cells(c,3) = cells(i,1)
c=c+1
i=i+1
end if
Loop
End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
Vos techniques me paraissent la bonne méthode, je vais m'en inspirer. Je vous direz si j'ai réussi d'ici peu
Puis-je enregistrer la valeur d'une case (6 chiffres maximum, positif) de cette manière ? :
Puis-je enregistrer la valeur d'une case (6 chiffres maximum, positif) de cette manière ? :
DIM x as long x=cells(1;1).value
Bonjour,
Effectivement, un nombre à 6 chiffres, sans décimales, est stocké en VBA sous le type Long. Pour info, Long : Nombre entier codé sur 4 octets (32 bits) et dont la valeur est comprise entre -2 147 483 648 et 2 147 483 647.
Le code que tu donnes est donc exact.
Pour continuer sur ta question initiale, ta liste de nombres est longue? combien de lignes?
Effectivement, un nombre à 6 chiffres, sans décimales, est stocké en VBA sous le type Long. Pour info, Long : Nombre entier codé sur 4 octets (32 bits) et dont la valeur est comprise entre -2 147 483 648 et 2 147 483 647.
Le code que tu donnes est donc exact.
Pour continuer sur ta question initiale, ta liste de nombres est longue? combien de lignes?
Alors, si j'ai bien compris, il s'agit juste d'une partie d'une plus grosse procédure?
Si tel est le cas, j'alimenterais deux variables tableaux pour pouvoir les restituer ultérieurement dans le code.
Comme ceci :
Si tel est le cas, j'alimenterais deux variables tableaux pour pouvoir les restituer ultérieurement dans le code.
Comme ceci :
Option Explicit
Sub ReconstitutionAvecEtSansDoubles()
'déclaration des variables
Dim TabloDoublons() 'As Long 'apostrophe à ôter si on est sur que ce ne sont que des nombres
Dim TabloSingle() 'As Long 'apostrophe à ôter si on est sur que ce ne sont que des nombres
Dim DrLig As Integer, Lig As Integer, Ind1 As Integer, Ind2 As Integer
'les variables Ind servent d'indices à nos variables tableaux.
Ind1 = 0
Ind2 = 0
'DrLig stocke le numéro de la dernière ligne col A de la feuille Feuil1 A ADAPTER
DrLig = Sheets("Feuil1").Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row
'on boucle sur toutes les lignes de la colonne A
For Lig = 1 To DrLig
'Si NB.SI(ColonneA, ActiveCell) > 1 (si on a la même valeur plus d'une fois)
If WorksheetFunction.CountIf(Columns(1), Cells(Lig, 1).Value) > 1 Then
'alors on la stocke dans la variable tableaux "doublons"
ReDim Preserve TabloDoublons(Ind1)
TabloDoublons(Ind1) = Cells(Lig, 1).Value
Ind1 = Ind1 + 1
'sinon, donc si NB.SI(ColonneA, ActiveCell) = 1 (si on a la même valeur qu'une fois)
Else
'alors on la stocke dans la variable tableaux "Single"
ReDim Preserve TabloSingle(Ind2)
TabloSingle(Ind2) = Cells(Lig, 1).Value
Ind2 = Ind2 + 1
End If
'et on passe à la cellule suivante
Next
'A partir d'ici, les 6 lignes de code suivants restituent les valeurs contenues dans nos variables
'tableaux respectivement en colB et col C.
'si tu veux voir le résultat, enlève les apostrophes au début de chacune de ces lignes
'For Lig = 0 To UBound(TabloDoublons)
' Cells(Lig + 1, 2) = TabloDoublons(Lig)
'Next
'For Lig = 0 To UBound(TabloSingle)
' Cells(Lig + 1, 3) = TabloSingle(Lig)
'Next
End Sub
Voila je suis enfin parvenu à un résultat correct grâce à vos code et vos idées, mon code est basic mais fonctionne. Merci
J'ai fais encore plus simple, de ma liste, tout les numéros seul sont déplacés vers une autre page et de ce fait j'aurais ma séparation. Les lignes vides seront supprimer par la suite.
Sub Séparation_Multiconducteurs()
Si quelqu'un veut s'amuser à l'optimiser, je ne suis pas contre, car pour l'instant ce n'est pas dans mes priorités.
Sujet résolu
Merci à tous, bonne continuation
J'ai fais encore plus simple, de ma liste, tout les numéros seul sont déplacés vers une autre page et de ce fait j'aurais ma séparation. Les lignes vides seront supprimer par la suite.
Sub Séparation_Multiconducteurs()
Dim mémorisation As Long
Dim nb_ligne As Integer
Dim ligne As Integer
Dim boucle_ligne As Boolean
Sheets("M_3,2").Select
nb_ligne = Cells.Find("*", , , , , xlPrevious).Row
ligne = 1
mémorisation = Cells(ligne, 1).Value
retour:
If boucle_ligne = False Then
If WorksheetFunction.CountIf(Columns(1), Cells(ligne, 1).Value) = 1 Then
Rows(ligne).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("M_3,2_U").Select
Rows(ligne).Select
ActiveSheet.Paste
Sheets("M_3,2").Select
Rows(ligne).Select
Selection.ClearContents
End If
If ligne = nb_ligne Then boucle_ligne = True
ligne = ligne + 1
GoTo retour
End If
Si quelqu'un veut s'amuser à l'optimiser, je ne suis pas contre, car pour l'instant ce n'est pas dans mes priorités.
Sujet résolu
Merci à tous, bonne continuation
