Macro excel récalcitrante
Résolu
clarisse
-
f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention -
f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention -
Bonjour,
Je cherche à automatiser une fonction qui fonctionne et à la rendre plus élégante.
J'ai un classeur excel avec un certain nombre de feuilles, toutes nommées selon l'activité qu'elles traitent. Dans une dernière feuille, qui me servira de résumé, je souhaite établir un tableau, à 6 colonnes (une colonne par activité), et dans chaque colonne, je désire avoir une liste de textes. A l'heure actuelle, une fonction =si('activitéA'!L9>2498;'activitéA'!D9;" ") me donne une colonne dans laquelle j'ai le texte de la casse D9 de mon activité A uniquement si ma valeur dépasse le seuil que j'ai fixé à 2498. Sinon, je n'ai rien d'affiché à l'écran, ce qui me donne un grand nombre de cellules ne contenant qu'un espace entre deux cellules contenant du texte. j'aimerai éliminer ces cellules "vierges"
J'ai pensé réaliser une macro, mais je n'ai jamais rencontré vba avant aujorud'hui... Notre confrontation a été houleuse ;-) !
Voila donc ce que j'ai, grâce à des questions posées sur ce forum, réussi à bidouiller, mais quelqu'un pourrait-il me corriger car ça bug svp? Un grand merci d'avance!
Sub riskmajbri()
'
' Si la valeur de la colonne L est supérieur à un seuil, affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante. le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("Plan d'action").Activate
' feuille de destination
Col = "i" ' colonne données non vides à tester'
i = 12
NumLig = 7 ' 1° N° de la 1er ligne de données .... ? '
With Sheets("PR1422-Briqueter") ' feuille source'
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données'
While "PR1422-Briqueter"R[2]C[i]<2498,NumLig = NumLig + 1
"=If('PR1422-Briqueter'!R[2]C[4]>2498,'PR1422-Briqueter'!R[2]C[-4], NumLig = NumLig + 1)"
NumLig = NumLig + 1
Sheets("Plan d'action").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
End While
Next
End With
Je cherche à automatiser une fonction qui fonctionne et à la rendre plus élégante.
J'ai un classeur excel avec un certain nombre de feuilles, toutes nommées selon l'activité qu'elles traitent. Dans une dernière feuille, qui me servira de résumé, je souhaite établir un tableau, à 6 colonnes (une colonne par activité), et dans chaque colonne, je désire avoir une liste de textes. A l'heure actuelle, une fonction =si('activitéA'!L9>2498;'activitéA'!D9;" ") me donne une colonne dans laquelle j'ai le texte de la casse D9 de mon activité A uniquement si ma valeur dépasse le seuil que j'ai fixé à 2498. Sinon, je n'ai rien d'affiché à l'écran, ce qui me donne un grand nombre de cellules ne contenant qu'un espace entre deux cellules contenant du texte. j'aimerai éliminer ces cellules "vierges"
J'ai pensé réaliser une macro, mais je n'ai jamais rencontré vba avant aujorud'hui... Notre confrontation a été houleuse ;-) !
Voila donc ce que j'ai, grâce à des questions posées sur ce forum, réussi à bidouiller, mais quelqu'un pourrait-il me corriger car ça bug svp? Un grand merci d'avance!
Sub riskmajbri()
'
' Si la valeur de la colonne L est supérieur à un seuil, affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante. le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("Plan d'action").Activate
' feuille de destination
Col = "i" ' colonne données non vides à tester'
i = 12
NumLig = 7 ' 1° N° de la 1er ligne de données .... ? '
With Sheets("PR1422-Briqueter") ' feuille source'
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données'
While "PR1422-Briqueter"R[2]C[i]<2498,NumLig = NumLig + 1
"=If('PR1422-Briqueter'!R[2]C[4]>2498,'PR1422-Briqueter'!R[2]C[-4], NumLig = NumLig + 1)"
NumLig = NumLig + 1
Sheets("Plan d'action").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
End While
Next
End With
A voir également:
- Macro excel récalcitrante
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Liste déroulante excel - Guide
- Word et excel gratuit - Guide
- Déplacer colonne excel - Guide
- Si ou excel - Guide
2 réponses
Bonjour,
Si j'ai bien compris ce que vous vouliez, cela devrait convenir.
A adapter pour boucler sur toutes les activites.
Sub riskmajbri()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Const Val_test = 2498
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
With Sheets("PR1422-Briqueter") ' feuille source'
NumLig = 7 ' 1° N° de la 1er ligne de données .... ? '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données'
'Test cellule < a constante valeur
If .Cells(Lig, Col) < Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 4) = .Cells(Lig, Col)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
End Sub
Bon courage (VBA n'a jamais mordu de personne, a ma connaissance, mais.....)
Si j'ai bien compris ce que vous vouliez, cela devrait convenir.
A adapter pour boucler sur toutes les activites.
Sub riskmajbri()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Const Val_test = 2498
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
With Sheets("PR1422-Briqueter") ' feuille source'
NumLig = 7 ' 1° N° de la 1er ligne de données .... ? '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données'
'Test cellule < a constante valeur
If .Cells(Lig, Col) < Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 4) = .Cells(Lig, Col)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
End Sub
Bon courage (VBA n'a jamais mordu de personne, a ma connaissance, mais.....)
Bonjour,
macro pour tous les onglets a tester
Sub riskmaj()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Dim Nom_Onglet(10)
Const Nb_Onglet = 6
Nom_Onglet(0) = "PR1410-Pr de Management"
Nom_Onglet(1) = "PR1421-Réceptionner et envoyer"
Nom_Onglet(2) = "PR1422-Briqueter"
Nom_Onglet(3) = "PR1423-Fondre & Couler"
Nom_Onglet(4) = "PR1433-Analyser"
Nom_Onglet(5) = "PR1432-Maintenir"
Nom_Onglet(6) = ""
Nom_Onglet(7) = ""
Nom_Onglet(8) = ""
Const Val_test = 999
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
For Pointeur = 0 To Nb_Onglet
With Sheets(Nom_Onglet(Pointeur)) ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 2 + Pointeur) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
Next x
End Sub
Bon courage
macro pour tous les onglets a tester
Sub riskmaj()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Dim Nom_Onglet(10)
Const Nb_Onglet = 6
Nom_Onglet(0) = "PR1410-Pr de Management"
Nom_Onglet(1) = "PR1421-Réceptionner et envoyer"
Nom_Onglet(2) = "PR1422-Briqueter"
Nom_Onglet(3) = "PR1423-Fondre & Couler"
Nom_Onglet(4) = "PR1433-Analyser"
Nom_Onglet(5) = "PR1432-Maintenir"
Nom_Onglet(6) = ""
Nom_Onglet(7) = ""
Nom_Onglet(8) = ""
Const Val_test = 999
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
For Pointeur = 0 To Nb_Onglet
With Sheets(Nom_Onglet(Pointeur)) ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 2 + Pointeur) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
Next x
End Sub
Bon courage
f894009 tu es un programmateur hors pair!
Juste deux valeurs qui n'allaient pas, mais sinon ça fonctionne avec :
(Je me suis même permise de m'amuser à supprimer les doublons en plus, comme quoi tu avais raison, VBA n'est peut-être pas si hargneux après tout :-) )
Sub riskmajglobal()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Dim Nom_Onglet(10)
Const Nb_Onglet = 5
Nom_Onglet(0) = "PR1410-Pr de Management"
Nom_Onglet(1) = "PR1421-Réceptionner et envoyer"
Nom_Onglet(2) = "PR1422-Briqueter"
Nom_Onglet(3) = "PR1423-Fondre & Couler"
Nom_Onglet(4) = "PR1433-Analyser"
Nom_Onglet(5) = "PR1432-Maintenir"
Nom_Onglet(6) = ""
Nom_Onglet(7) = ""
Nom_Onglet(8) = ""
Const Val_test = 999
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
For Pointeur = 0 To Nb_Onglet
With Sheets(Nom_Onglet(Pointeur)) ' feuille source'
NumLig = 2 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 2 + Pointeur) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
Next
Columns("B:B").Select
ActiveSheet.Range("$B$1:$B$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$C$1:$C$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$D$1:$D$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$E$1:$E$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$F$1:$F$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$G$1:$G$186").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Juste deux valeurs qui n'allaient pas, mais sinon ça fonctionne avec :
(Je me suis même permise de m'amuser à supprimer les doublons en plus, comme quoi tu avais raison, VBA n'est peut-être pas si hargneux après tout :-) )
Sub riskmajglobal()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Dim Nom_Onglet(10)
Const Nb_Onglet = 5
Nom_Onglet(0) = "PR1410-Pr de Management"
Nom_Onglet(1) = "PR1421-Réceptionner et envoyer"
Nom_Onglet(2) = "PR1422-Briqueter"
Nom_Onglet(3) = "PR1423-Fondre & Couler"
Nom_Onglet(4) = "PR1433-Analyser"
Nom_Onglet(5) = "PR1432-Maintenir"
Nom_Onglet(6) = ""
Nom_Onglet(7) = ""
Nom_Onglet(8) = ""
Const Val_test = 999
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
For Pointeur = 0 To Nb_Onglet
With Sheets(Nom_Onglet(Pointeur)) ' feuille source'
NumLig = 2 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 2 + Pointeur) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
Next
Columns("B:B").Select
ActiveSheet.Range("$B$1:$B$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$C$1:$C$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$D$1:$D$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$E$1:$E$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$F$1:$F$186").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("$G$1:$G$186").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Mille merci, après quelques modifications (je n'ai peut être pas été tout à fait claire dans mes explications, et sans le fichier ce doit être difficile de coder, ça fonctionne!!! Miraculeux! Ce matin, j'ai appris que mon seuil avait changé, mais c'est ce qui est super avec une macro, s'il y a un changement, la modification est vite réalisée, et le tableau mouline tout seul! J'ai réussi à faire de cette macro un travail sur toutes mes colonnes, donc une seule macro pour mes 6 activités!!! J'en ferai encore d'autres macros si je me découvre des affinités particulières avec VBA, mais s'il ne m'a pas encore mordu, j'ai eu droit à une belle migraine! Mais la satisfaction d'avoir réussi, c'est que du bonheur, un immense merci pour ce déblocage!!!
Toujours est-il que le code devient :
Sub riskmaj()
' Si la valeur de la colonne L est supérieur à un seuil,
' affiche le texte de la colonne D correspondant
' dans une autre feuille, sinon, teste la valeur suivante.
' le résultat est un tableau de textes sans interligne.
'
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Const Val_test = 999
'feuille de destination
Worksheets("Plan d'action").Activate
Col = "L" ' colonne données non vides à tester'
With Sheets("PR1410-Pr de Management") ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 2) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
With Sheets("PR1421-Réceptionner et envoyer") ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 3) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
With Sheets("PR1422-Briqueter") ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 4) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
With Sheets("PR1423-Fondre & Couler") ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 5) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
With Sheets("PR1433-Analyser") ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 6) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
With Sheets("PR1432-Maintenir") ' feuille source'
NumLig = 8 ' 1° N° de la 1er ligne de données '
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 8 To NbrLig 'n° de la 1ere ligne de données jusqu'à la dernière ligne non vide'
'Test cellule > à constante valeur
If .Cells(Lig, Col) > Val_test Then
'copie valeur
Sheets("Plan d'action").Cells(NumLig, 7) = .Cells(Lig, 4)
'Incremente ligne
NumLig = NumLig + 1
End If
Next Lig
End With
End Sub