Compter valeurs uniques + Condition

M

MsVixene

XLDnaute Nouveau
Bonjour,

j'ai un fichier de suivi pour réaliser des inventaires.

Les biens sont identifiés par des N°d'inventaire, eux mêmes composés de plusieurs lignes, localisés dans des N° de locaux.
On retrouve tout genre de numéros d'inventaire (Chiffres, lettres, chiffres+lettres)

J'ai donc besoin d'aide sur 3 points :

Dans un autre sujet, on vient de créer une maccro qui permet de dire si les N° d'inventaire de l'onglet EXTRACTION sont inventoriables ou non, en fonction de la liste de l'onglet A ENLEVER. (On dit NON si le N° d'inventaire est dans les deux listes, sinon OUI).

Dans le module 4 :
La colonne 10 de longlet EXTRACTION n'existant pas quand on fait l'extraction SAP, j'aimerais copier/coller la mise en forme seulement de la colonne d'avant. J'ai donc fait un petit code avec l'assistant vu que je ne sais pas faire grand chose. Mais la sélection copier ne s'en va pas pour autant, alors que j'ai bien mis un range select après.
Je renomme également la colonne.

J'aimerais rajouter une textBox pendant que la maccro s'exécute car il y a 17000 lignes, donc j'aimerais qu'on patiente pendant ces quelques secondes. J'ai mis une ligne de code mais comment faire pour que la textbox reste ?

Dans le module 2 :
Cette maccro permet de compter le nombre unique N° de locaux des onglets EXTRACTION et RESULTAT, et le nombre unique de N° d'inventaire, puis de le renseigner dans l'onglet POINT A DATE. Seulement, j'aimerais maintenant prendre en compte que l'on sait si le N° d'inventaire doit être inventorié. Donc clairement:
Si pour une ligne, la colonne 10 = OUI, alors compter.
Si pour une ligne, la colonne 10 = NON, alors ne pas compter.

Merci bicoup.
 
Dernière édition:
Trier par date Trier par votes
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Compter valeurs uniques + Condition

Bonjour.

Pour le module4 je propose cette écriture :
VB: 
Sub ÀInventorierOuiNon()
Dim FExt As Worksheet, TExtr(), TÀEnl(), Lx&, Le&, NuExtr As String
Set FExt = Worksheets("EXTRACTION"): TExtr = Range(FExt.[B2], FExt.Cells(FExt.Rows.Count, "B").End(xlUp)).Value
With Worksheets("A enlever"): TÀEnl = .Range(.[A1], .Cells(.Rows.Count, "A").End(xlUp)).Value: End With
For Le = 1 To UBound(TÀEnl): TÀEnl(Le, 1) = Replace(TÀEnl(Le, 1), "%", "*"): Next Le
FExt.[J1].Value = "À inv."
FExt.[I1].Resize(UBound(TExtr) + 1).Copy
FExt.[J1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
For Lx = 1 To UBound(TExtr)
   NuExtr = TExtr(Lx, 1)
   TExtr(Lx, 1) = "Oui"
   For Le = 1 To UBound(TÀEnl)
      If NuExtr Like TÀEnl(Le, 1) Then TExtr(Lx, 1) = "Non": Exit For
      Next Le, Lx
FExt.[J2].Resize(UBound(TExtr)).Value = TExtr
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
M

MsVixene

XLDnaute Nouveau
Re : Compter valeurs uniques + Condition

Tu as changé tout le code lol :O

Mais ça a l'air de fonctionner très bien ! Par contre pour la textbox du coup ? C'est possible qu'elle s'affiche pendant l'exécution ? PArce que là, il y a peu de lignes mais dans le fichier réel, c'est pas la même ^^
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Compter valeurs uniques + Condition

Oui, mais ça devrait être beaucoup plus rapide … pour moins de 10000 lignes de chaque coté, quand même, évidemment. Sinon il faudrait passer la vitesse supérieur en utilisant des fournitures de OutIdx.
Remarque: j'ai encore édité le dernier poste.
 
Vote positif 0 Vote négatif
M

MsVixene

XLDnaute Nouveau
Re : Compter valeurs uniques + Condition

J'explique un peu mieux le fichier :

dans l'onglet DONNEEES, je viens coller des lignes qui sont traitées par le module 5 CopyFormula, et viennent dans l'onglet RESULTAT. Je peux comme ça faire le suivi.

Le module 2 permet de compter le nombre de N° d'inventaire UNIQUE des onglets EXTRACTION et RESULTAT (pardon, je me suis trompée, plus haut), ainsi que le nombre unique de local de ces deux mêmes onglets. Elle renseigne le résultat dans les cellules indiquées dans l'onglet POINT A DATE.
Je peux de cette manière savoir combien on a inventorié de matériels et combien il en reste.

Tout est dans le Combien en reste-t-il

Jusque là, on comptait TOUS les N°Inventaire et Locaux restant, sans distinguer ceux qui sont "A inventorier".

Donc en fait, il faudrait rajouter la condition que si le bien est à inventorier, alors compter en tant qu'unique.

Est-ce plus clair ? :)
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Compter valeurs uniques + Condition

Petite modification pour le comptage


Code: 
Sub ÀInventorierOuiNon()
Dim FExt As Worksheet, TExtr(), TÀEnl(), Lx&, Le&, NuExtr As String

'Modif 1 ici
Dim Compte As Long

Set FExt = Worksheets("EXTRACTION"): TExtr = Range(FExt.[B2], FExt.Cells(FExt.Rows.Count, "B").End(xlUp)).Value
With Worksheets("A enlever"): TÀEnl = .Range(.[A1], .Cells(.Rows.Count, "A").End(xlUp)).Value: End With
For Le = 1 To UBound(TÀEnl): TÀEnl(Le, 1) = Replace(TÀEnl(Le, 1), "%", "*"): Next Le
FExt.[J1].Value = "À inv."
FExt.[I1].Resize(UBound(TExtr) + 1).Copy
FExt.[J1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

'Modif 2 ici
Compte = UBound(TExtr)

For Lx = 1 To UBound(TExtr)
   NuExtr = TExtr(Lx, 1)
   TExtr(Lx, 1) = "Oui"
   For Le = 1 To UBound(TÀEnl)  
                                                                                 'Modif 3 ici  
      If NuExtr Like TÀEnl(Le, 1) Then TExtr(Lx, 1) = "Non": Compte = Compte - 1: Exit For
      Next Le, Lx
FExt.[J2].Resize(UBound(TExtr)).Value = TExtr

'Modif 4 ici
MsgBox "Nombre à inventorier : " & Compte
End Sub
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Compter valeurs uniques + Condition

Changes le module complet cela ira plus vite ,

et s'y elle te genes tu peux enlever la derniere msgbox

Voilà, voilà


Code: 
Sub ÀInventorierOuiNon()
Dim FExt As Worksheet, TExtr(), TÀEnl(), Lx&, Le&, NuExtr As String

'Modif 1 ici
Dim Compte As Long

Set FExt = Worksheets("EXTRACTION"): TExtr = Range(FExt.[B2], FExt.Cells(FExt.Rows.Count, "B").End(xlUp)).Value
With Worksheets("A enlever"): TÀEnl = .Range(.[A1], .Cells(.Rows.Count, "A").End(xlUp)).Value: End With
For Le = 1 To UBound(TÀEnl): TÀEnl(Le, 1) = Replace(TÀEnl(Le, 1), "%", "*"): Next Le
FExt.[J1].Value = "À inv."
FExt.[I1].Resize(UBound(TExtr) + 1).Copy
FExt.[J1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

'Modif 2 ici
Compte = UBound(TExtr)

For Lx = 1 To UBound(TExtr)
   NuExtr = TExtr(Lx, 1)
   TExtr(Lx, 1) = "Oui"
   For Le = 1 To UBound(TÀEnl)  
                                                                                 'Modif 3 ici  
      If NuExtr Like TÀEnl(Le, 1) Then TExtr(Lx, 1) = "Non": Compte = Compte - 1: Exit For
      Next Le, Lx
FExt.[J2].Resize(UBound(TExtr)).Value = TExtr

'Modif 4 ici
MsgBox "Nombre à inventorier : " & Compte
sheets("POINT A DATE").range("E22")=compte 
End Sub
l
 
Vote positif 0 Vote négatif
M

MsVixene

XLDnaute Nouveau
Re : Compter valeurs uniques + Condition

Ce n'est pas dans ce module que je souhaitais la modification par contre !
C'est dans le module 2 :

PHP: 
Function NbUnique&(Rg As Range)
               Dim Rc As Range
    If Rg.Count = 1 Then _
        With Rg.Parent: Set Rg = .Range(Rg, .Cells(.Rows.Count, Rg.Column).End(xlUp)): End With
 
    With CreateObject("Scripting.Dictionary")
        For Each Rc In Rg
            If Not .Exists(Rc.Value) Then .Add Rc.Value, ""
        Next
 
        NbUnique = .Count:  .RemoveAll
    End With
End Function

Sub CountUniqueItem()
 
Dim RgInventaireResultat As Range
Dim RgLocalResultat As Range
Dim RgInventaireExtraction As Range
Dim RgLocalExtraction As Range
Dim LastLine As Single
 
LastLine = CountLig(Worksheets("RESULTAT"), 3)
Set RgInventaireResultat = Worksheets("RESULTAT").Range("C2:C" & CStr(LastLine))
 
LastLine = CountLig(Worksheets("RESULTAT"), 2)
Set RgLocalResultat = Worksheets("RESULTAT").Range("B2:B" & CStr(LastLine))

LastLine = CountLig(Worksheets("EXTRACTION"), 2)
Set RgInventaireExtraction = Worksheets("EXTRACTION").Range("B2:B" & CStr(LastLine))
 
LastLine = CountLig(Worksheets("EXTRACTION"), 1)
Set RgLocalExtraction = Worksheets("EXTRACTION").Range("A2:A" & CStr(LastLine))
 
Worksheets("POINT A DATE").Cells(9, 5).Value = NbUnique(RgLocalResultat)
Worksheets("POINT A DATE").Cells(9, 7).Value = NbUnique(RgInventaireResultat)
Worksheets("POINT A DATE").Cells(14, 5).Value = NbUnique(RgLocalExtraction)
Worksheets("POINT A DATE").Cells(14, 7).Value = NbUnique(RgInventaireExtraction)
 
End Sub

EDIT : Le module 4 est OK, pas de comptage dedans!
 
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Compter valeurs uniques + Condition

Toujours pas sûr d'avoir compris, mais peut être que si: Prévoyez une 2ième colonne optionnelle en paramètre de NbUnique pour les "Oui":
VB: 
Function NbUnique&(ByVal RgSuj As Range, Optional ByVal RgÀInv As Range)
Dim TSuj(), L&, TÀInv()
If RgSuj.Count = 1 Then With RgSuj.EntireColumn: Set RgSuj = Range(RgSuj, .Rows(.Rows.Count).End(xlUp)): End With
TSuj = RgSuj.Value
With New Scripting.Dictionary ' Implique référence "Microsoft Scripting Runtime" ' CreateObject("Scripting.Dictionary")
   If RgÀInv Is Nothing Then
      For L = 1 To UBound(TSuj): .Item(TSuj(L, 1)) = Empty: Next L
   Else
      TÀInv = Intersect(RgÀInv.EntireColumn, RgSuj.EntireRow).Value
      For L = 1 To UBound(TSuj)
         If TÀInv(L, 1) = "Oui" Then .Item(TSuj(L, 1)) = Empty
         Next L: End If
   NbUnique = .Count: End With
End Function
À tester…

Pour pouvoir l'utiliser avec la feuille RESULTAT, il faudra naturellement y reporter les "Oui" et les "Non".
 
Dernière édition:
Vote positif 0 Vote négatif
M

MsVixene

XLDnaute Nouveau
Re : Compter valeurs uniques + Condition

Du coup, je ne sais pas ce que tu as compris lol

J'ai une erreur de compilation à la première ligne (en jaune) et en sélection le With New Scriopting.Dictionnary.

Je reformule :
je voudrais juste que ma maccro compte les valeurs uniques des lignes où il y a OUI en colonne 10 de EXTRACTION (dans l'onglet RESULTAT il n'y a rien à changer pardon!) pour mettre l'info dans POINT A DATE.

J'ai une autre maacro qui marchait peut être est-ce plus claire à adapter :

Code: 
Sub CountUniqueItem()
 
Dim UniqueInventaireResultat As New Collection
Dim UniqueLocalResultat As New Collection
Dim UniqueInventaireExtraction As New Collection
Dim UniqueLocalExtraction As New Collection
Dim LastLine As Single
 
'Compter local de RESULTAT
LastLine = CountLig(Worksheets("RESULTAT"), 2)
On Error Resume Next
For Each Cel In Worksheets("RESULTAT").Range("B2:B" & CStr(LastLine))
    UniqueLocalResultat.Add Cel.Value, CStr(Cel.Value)
Next Cel
On Error GoTo 0
 
'Compter Inventaire de RESULTAT
LastLine = CountLig(Worksheets("RESULTAT"), 3)
On Error Resume Next
For Each Cel In Worksheets("RESULTAT").Range("C2:C" & CStr(LastLine))
    UniqueInventaireResultat.Add Cel.Value, CStr(Cel.Value)
Next Cel
On Error GoTo 0

'Compter Local de EXTRACTION
LastLine = CountLig(Worksheets("EXTRACTION"), 1)
On Error Resume Next
For Each Cel In Worksheets("EXTRACTION").Range("A2:A" & CStr(LastLine))
    UniqueLocalExtraction.Add Cel.Value, CStr(Cel.Value)
Next Cel
On Error GoTo 0

'Compter Inventaire de EXTRACTION
LastLine = CountLig(Worksheets("EXTRACTION"), 2)
On Error Resume Next
For Each Cel In Worksheets("EXTRACTION").Range("B2:B" & CStr(LastLine))
    UniqueInventaireExtraction.Add Cel.Value, CStr(Cel.Value)
Next Cel
On Error GoTo 0

'Afficher résultat
 
Worksheets("POINT A DATE").Cells(9, 5).Value = UniqueLocalResultat.Count
Worksheets("POINT A DATE").Cells(9, 7).Value = UniqueInventaireResultat.Count
Worksheets("POINT A DATE").Cells(14, 5).Value = UniqueLocalExtraction.Count
Worksheets("POINT A DATE").Cells(14, 7).Value = UniqueInventaireExtraction.Count
End Sub

J'ai ça sur un autre module mais je ne sais pas si ça va avec :

Code: 
Sub test()

Function CountLig(Ws As Worksheet, col As Single)
 
'Fonction servant à compter les lignes
 
On Error GoTo ErrorHandler
 
CountLig = Ws.Columns(col).Find("*", , , , xlByRows, xlPrevious).Row
 
Exit Function
 
ErrorHandler:
    CountLig = 1
 
End Function
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Re : Compter valeurs uniques + Condition

Bonjour.
La manipulation aisée et rapide des Dictionary exige la bibliothèque Scripting, fichier C:\WINDOWS\System32\scrrun.dll
Veillez donc à ce que "Microsoft Scripting Runtime" soit bien coché dans la liste Références disponibles, menus Outils, Références…
Je déteste les liaisons tardives introduites par l'utilisation du type Object, surtout pour les Dictionnary: c'est gâcher par une connerie de programmeur flemmard un bon dixième des gain de performance qu'il introduisent.
Oui si vous indiquez en second paramètre de cette nouvelle fonction NbUnique, pour la EXTRACTION seulement, une cellule de la colonne 10, il ne devrait comptabiliser que ceux qui contienne "Oui" ("OUI" ni "oui" ne marcheraient pas).
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
XL 2016 Compter les valeurs uniques dans une liste
Réponses
3
Affichages
135
F22Raptor
F
O
  • Question
XL 2016 Compter des cellules dont les données sont consécutives
Réponses
0
Affichages
220
oscarette
O
F
  • Résolu(e)
Microsoft 365 Mise en forme conditionnelle selon la référence d'une cellule
Réponses
3
Affichages
192
filiph79
F
Akortys
  • Question
Microsoft 365 RESOLU - Macro - Recherche de lignes identiques et ressortir les lignes uniques
Réponses
2
Affichages
284
Akortys
Akortys
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
153
sebastien176
S
R
  • Résolu(e)
Microsoft 365 Nombre de valeurs différentes suivant 2 critères
Réponses
10
Affichages
433
raf26
R
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
200
marie3107
M
3
  • Question
XL 2013 Recherche a plusieurs critéres
Réponses
2
Affichages
275
Gégé-45550
Gégé-45550
Z
  • Question
XL 2021 VBA Prélèvement d'une donnée si une valeur recherchée est identique
Réponses
3
Affichages
222
ZiM
Z
A
  • Question
XL 2016 Contrôle de la pose de 10 jours de congés consécutifs
Réponses
5
Affichages
383
djidji59430
djidji59430

Membres actuellement en ligne

22 membres et 306 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 484
Messages
2 088 800
Membres
103 971
dernier inscrit
abdazee