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

Fermé

cedrixxx Messages postés 34 Date d'inscription jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 - 4 oct. 2016 à 16:34
cedrixxx Messages postés 34 Date d'inscription jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 - 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,

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
Combien y a-t-il de bateaux dans la zone de 475 pixels de large et 1000 pixels de haut à partir du coin supérieur gauche de cette image ? - Forum Photoshop
Combien y a-t-il de bateaux dans la zone de 1500 pixels de large et 500 pixels de haut à partir du coin supérieur gauche de cette image ? - Forum Graphisme
Formule excel si contient texte alors valeur ✓ - Forum Excel

2 réponses

Réponse 1 / 2

gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 711
4 oct. 2016 à 21:40

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 jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 1
Modifié par cedrixxx le 5/10/2016 à 13:55

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 jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 1
10 oct. 2016 à 11:54

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 jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 1
18 oct. 2016 à 13:05

Dsl pour le up mais bon...

gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 711
21 oct. 2016 à 22:12

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 jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 1 > gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020
24 oct. 2016 à 11:12

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 jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 1 > cedrixxx Messages postés 34 Date d'inscription jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016
Modifié par cedrixxx le 24/10/2016 à 15:32

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 jeudi 8 juillet 2010 Statut Membre Dernière intervention 28 octobre 2016 1
28 oct. 2016 à 13:57

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

lien copié

Comment retrouver des lien copier sur sont téléphone

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

manon

copie de texte