Macro qui copie colle si la valeur est supérieur a 0%

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention -
cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention - 28 oct. 2016 à 13:57

Re/Bonjour,

J'ai déjà demander de l'aide pour un problème similaire mais je n'arrive pas à l'adapter j'aimerais copier/ coller une série de chiffes en pourcentage obtenue via une formule (si possible en gardant le lien entre les donnés sources et but) en ne gardant que les résultats >0 et la cellule associé d'une autre colonne

Option Explicit

' constantes à modifier selon ta configuration
' Feuille Source
Const FS = "Listing-machine"
Const lidebFS = 2
Const comacFS = "C"
Const coerrFS = "AI"
' Feuille But
Const FB = "Graph"
Const celdebFB = "A14"
' message recherché
'Const s = "Machine non répertorié" <= J'aimerais pouvoir mettre >0%

Public Sub TOK()

Dim liFS As Long, lifinFS As Long
Dim dico As Object, cle As String, cles, nbcles As Long
' dictionnaire des machines en erreur
Set dico = CreateObject("scripting.dictionary")
With Sheets(FS)
lifinFS = .Range(comacFS & Rows.Count).End(xlUp).Row
For liFS = lidebFS To lifinFS
If Value <> "" And c.Offset(0, décalage).Value <> 0 Then .Range(coerrFS & liFS).Value

cle = .Range(comacFS & liFS).Value
If (Not dico.exists(cle)) Then dico.Add cle, 1
End If
Next liFS
End With
nbcles = dico.Count
cles = dico.keys
' resultat
With Sheets(FB)
.Range(celdebFB).Resize(1000, 1).ClearContents
.Range(celdebFB).Offset(-1, 0).Value = s
.Range(celdebFB).Resize(nbcles, 1) = Application.Transpose(cles)
End With
End Sub

Merci d'avance,

Afficher la suite

A voir également:

Macro qui copie colle si la valeur est supérieur a 0%
Copie cachée - Guide
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Copie écran samsung - Guide
Copie disque dur - Guide
Lien copié - Forum Mobile

2 réponses

Réponse 1 / 2

gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention 4 724

Bonjour,

Tu remplaces

'Const s = "Machine non répertorié" <= J'aimerais pouvoir mettre >0%

par

Const s = ">0%"

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention 1

Bonjour gbinforme,

J'ai tjrs nbcles=0

J'ai tester s=1 ce qui me donne tout les équipements a 100% c'est malheureusement l'inverse que je souhaiterais et pour s = "<1" j'ai nbcles=0

Je suppose donc que les symbole <> sont dérangeante

Je m'en suis tirer en faisant a l'envers j'ai donc désormais

Const s As Integer = "1"

 If s <> .Range(coerrFS & liFS).Value And s <> 0 Then

Sauf qu'en cas de cellule vide j'ai quand même le copier coller qui se fait et j'aimerais copier également d'autre colonne un peux comme

Const comacFS = "C:B:AI"

Option Explicit

' constantes à modifier selon ta configuration
' Feuille Source
Const FS = "Listing-machine"
Const lidebFS = 2
Const comacFS = "C"
Const coerrFS = "AI"
' Feuille But
Const FB = "Graph"
Const celdebFB = "A20"
' message recherché

Const s As Integer = "1"

Public Sub Pareto()
Dim liFS As Long, lifinFS As Long
Dim dico As Object, cle As String, cles, nbcles As Long
' dictionnaire des machines en erreur
Set dico = CreateObject("scripting.dictionary")
With Sheets(FS)
  lifinFS = .Range(comacFS & Rows.Count).End(xlUp).Row
  For liFS = lidebFS To lifinFS
    
    If s <> .Range(coerrFS & liFS).Value And s <> 0 Then
  '  If s = .Range(coerrFS & liFS).Value Then
    
      cle = .Range(comacFS & liFS).Value
      If (Not dico.exists(cle)) Then dico.Add cle, 1
    End If
  Next liFS
End With
nbcles = dico.Count
cles = dico.keys
' resultat
With Sheets(FB)
  .Range(celdebFB).Resize(1000, 1).ClearContents
  .Range(celdebFB).Offset(-1, 0).Value = s
    .Range(celdebFB).Resize(nbcles, 1) = Application.Transpose(cles)
End With
End Sub

Cldmt,

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention 1

Je n'arrive vraiment pas a résoudre le problème donc si quelqu'un a des pistes je suis preneur

Réponse 2 / 2

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention 1

Dsl pour le up mais bon...

gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention 4 724

Bonjour cedrixxx,

J'ai testé ta procédure avec ce que j'ai compris et je ta suggère de modifier ces lignes :

Const s = 0

    If .Range(coerrFS & liFS).Value > s Then


  .Range(celdebFB).Offset(-1, 0).Value = ">" & s

Il me semble que tu devrais avoir ton résultat.

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention 1 > gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention

Je sais pas si ça peux éclaircir ma demande

J'ai un exemple ici: http://www.cjoint.com/c/FJtgFafWu5t

J'aimerais faire un Pareto (courbe ABC) automatiquement via VBA pour cela j'ai trouver un tableau dynamique sur le net (qui n'est pas présent sur le doc cijoint) mais il me faut pour cela copier
La cellule de la colonne B et C qui correspond a la cellule de la colonne AI quand AI et différent de vide et inférieur à 1 (100%) de la feuille listing machine
Le tout serais coller dans une autre feuille (Graph) et si possible du plus petit au plus grand (mais ça à la limite avec un filtre sa se fera sans vba).

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention 1 > cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention

Option Explicit

' constantes à modifier selon ta configuration
' Feuille Source
Const FS = "Listing-machine"
Const lidebFS = 8
Const comacFS = "C"
Const comacFS1 = "B"
Const comacFS2 = "AI"

Const coerrFS = "AI"
' Feuille But
Const FB = "Graph"
Const celdebFB = "A20"
Const celdebFB1 = "b20"
Const celdebFB2 = "c20"

' message recherché

Const s As Integer = "0"

Public Sub Pareto()
Dim liFS As Long, lifinFS As Long
Dim liFS1 As Long, lifinFS1 As Long
Dim liFS2 As Long, lifinFS2 As Long

Dim dico, dico1, dico2 As Object, cle, cle1, cle2 As String, cles, cles1, cles2, nbcles As Long
' dictionnaire des machines en erreur

Set dico = CreateObject("scripting.dictionary")
Set dico1 = CreateObject("scripting.dictionary")
Set dico2 = CreateObject("scripting.dictionary")

With Sheets(FS)
  
  lifinFS = .Range(comacFS & Rows.Count).End(xlUp).Row
   lifinFS1 = .Range(comacFS1 & Rows.Count).End(xlUp).Row
    lifinFS2 = .Range(comacFS2 & Rows.Count).End(xlUp).Row
  
 
  
  For liFS = lidebFS To lifinFS
   
    If .Range(coerrFS & liFS).Value > s And .Range(coerrFS & liFS).Value < 1 Then
'   If s <> .Range(coerrFS & liFS).Value And s <> 0 Then
  '  If s = .Range(coerrFS & liFS).Value Then
    
      cle = .Range(comacFS & liFS).Value
      cle1 = .Range(comacFS1 & liFS).Value
      cle2 = .Range(comacFS2 & liFS).Value
      
      If (Not dico.exists(cle)) Then dico.Add cle, 1
      If (Not dico1.exists(cle1)) Then dico1.Add cle1, 1
      If (Not dico2.exists(cle2)) Then dico2.Add cle2, 1
      
      
      
    End If
  Next liFS
End With
nbcles = dico.Count
cles = dico.keys
cles1 = dico1.keys
cles2 = dico2.keys
' resultat
With Sheets(FB)

  .Range(celdebFB).Resize(1000, 1).ClearContents
  .Range(celdebFB).Offset(-1, 0).Value = ">" & s
  .Range(celdebFB).Resize(nbcles, 1) = Application.Transpose(cles)
  
  .Range(celdebFB1).Resize(1000, 1).ClearContents
  .Range(celdebFB1).Offset(-1, 0).Value = s
  .Range(celdebFB1).Resize(nbcles, 1) = Application.Transpose(cles1)
  
  .Range(celdebFB2).Resize(1000, 1).ClearContents
  .Range(celdebFB2).Offset(-1, 0).Value = s
  .Range(celdebFB2).Resize(nbcles, 1) = Application.Transpose(cles2)
  
  
  
  
End With
End Sub

Alors voila sa marche sauf que pour certaines lignes j'ai:
6340111773822,38 au lieux de 99,5%
et #N/A pour
68,0% lignes : 110
92,1% 111

96,2% 115
78,1% 116

78,1% 120
98,7% 122

Ce qui est étrange c'est que les #N/A sont assez proche les un des autres dans ma feuille source, j'avoue ne pas trop comprendre.

cedrixxx Messages postés 34 Date d'inscription Statut Membre Dernière intervention 1

Je pense que le problème vient de là:
[code=vb] If (Not dico.exists(cle)) Then dico.Add cle, 1
If (Not dico1.exists(cle1)) Then dico1.Add cle1, 1
If (Not dico2.exists(cle2)) Then dico2.Add cle2, 1[/code]

Et plus exactement ici: [code=vb] If (Not dico2.exists(cle2)) Then dico2.Add cle2, 1[/code]

J'aimerais pouvoir faire [code=vb]If (Not dico.exists(cle)) Then dico.Add cle, 1 AND dico1.Add cle1, 1 AND dico2.Add cle2, 1 [/code]

Mais sa ne marche pas, si vous pouvez m'indiquer la syntaxe sa serais génial.

Discussions similaires

Copier un lien instagram

Retrouver liens copiés sur le téléphone

copie d'un lien dans le navigateur internet

faire afficher "0" à la place de #N/A

Info Free: Votre encours sur le service internet est supérieur à 10 €.

Votre réponse

Discussions similaires