Faire arrêter une macro

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion chemist
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
C

chemist

XLDnaute Junior
Bonjour je suis débutant en VBA, j'ai donc construit ma macro avec l'enregistreur de macro et avec des choses trouvés sur ce forum.

J'ai déja posé quelques questions sur cette macro et j'ai finalement trouvé des solutions. MAis comme je suis débutant et dans le but de mieux comprendre, si quelqu'un pouvait répondre a ma question sur un autre fil qui traite de la même macro ça serait très apprécié

Lien supprimé

Il y aurait également encore 2 amélioration que j'aimerais apporter à la macro.

1) Lorsqu'il n'y a pas de fichiers dans le répertoire choisi j'aimerais que la macro arrête immédiatement après le message qu' aucun fichier n'a été trouvé.

ca doit avoir rapport avec un end if ou quelque chose comme ça

2) Lorsque la fenêtre s'ouvre pour choisir le répertoire si je fais annulé j'ai un message d'erreur. Il y a t'il un moyen pour que la macro stop et que la fênetre se ferme.

j'ai copié la macro plus bas




merci d'avance pour vos réponses



Sub Lecture_Resis()
'
'
Set fichcherche = Application.FileSearch
With fichcherche

.LookIn = GetDirectory
.Filename = '*.z'
If .Execute > 0 Then
MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
Workbooks.Add
For I = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)
Rows('1:3').Select
Selection.Delete Shift:=xlUp
Rows('3:136').Select
Selection.Delete Shift:=xlUp
Rows('4:4').Select
Selection.Delete Shift:=xlUp
Columns('B😀').Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range('b1') = ActiveSheet.Name
Range('A:C').Select
Selection.Copy
Windows('zview_macro.xls').Activate
Sheets('calcul').Activate
Range('A:C').Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
For Each Wk In Workbooks
If Wk.Name <> ThisWorkbook.Name Then
Wk.Close savechanges:=False
End If
Next Wk
With Worksheets('calcul')
Application.CutCopyMode = True
.Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
.Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
.Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
.Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
.Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value


End With
On Error Resume Next
Next I
Else
MsgBox 'Aucun fichier n'a ete trouve'
End If
End With
Sheets('résultats').Select
Columns('A:e').Select
Selection.Sort Key1:=Range('c1'), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Select
Sheets('Macro').Activate
ActiveWindow.SelectedSheets.Visible = False
Sheets('résultats').Select
Range('f1').Select
sPath = Range('f1').Value
If Right(sPath, 1) <> '\\' Then sPath = sPath & '\\'
ActiveWorkbook.SaveAs sPath & ActiveSheet.Range('g1').Value

End Sub

Message édité par: chemist, à: 05/08/2005 06:13
 
Trier par date Trier par votes
Bonjour

Pour ton point 1 j'ai suligné en rouge ce qu'a dit Chris
Pour ton point 2 tu ajoutes ce qui est surligné en bleu

Sub Lecture_Resis()
'
'
Set fichcherche = Application.FileSearch
With fichcherche
On Error GoTo fin
.LookIn = GetDirectory
.Filename = '*.z'
If .Execute > 0 Then
MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
Workbooks.Add
For I = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)
Rows('1:3').Select
Selection.Delete Shift:=xlUp
Rows('3:136').Select
Selection.Delete Shift:=xlUp
Rows('4:4').Select
Selection.Delete Shift:=xlUp
Columns('B😀').Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range('b1') = ActiveSheet.Name
Range('A:C').Select
Selection.Copy
Windows('zview_macro.xls').Activate
Sheets('calcul').Activate
Range('A:C').Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
For Each Wk In Workbooks
If Wk.Name <> ThisWorkbook.Name Then
Wk.Close savechanges:=False
End If
Next Wk
With Worksheets('calcul')
Application.CutCopyMode = True
.Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
.Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
.Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
.Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
.Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value


End With
On Error Resume Next
Next I
Else
MsgBox 'Aucun fichier n'a ete trouve'
Exit sub
End If
End With
Sheets('résultats').Select
Columns('A:e').Select
Selection.Sort Key1:=Range('c1'), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Select
Sheets('Macro').Activate
ActiveWindow.SelectedSheets.Visible = False
Sheets('résultats').Select
Range('f1').Select
sPath = Range('f1').Value
If Right(sPath, 1) <> '' Then sPath = sPath & ''
ActiveWorkbook.SaveAs sPath & ActiveSheet.Range('g1').Value
fin:
End Sub

Message édité par: Pascal76, à: 05/08/2005 08:37
 
Vote positif 0 Vote négatif
Bonjour

ta macro un peu simplifiée, pas testé mais cela devrait fonctionner

A+
Code: 
Sub Lecture_Resis()
Dim Wsbk_Temp As Workbook
Dim Wsht_Calcul As Worksheet
Dim Wsht_Resultat As Worksheet
Set Wsht_Calcul = ThisWorkbook.Worksheets('calcul')
Set Wsht_Resultat = ThisWorkbook.Sheets('résultats')
Set fichcherche = Application.FileSearch
ThisWorkbook.Activate
With fichcherche
    On Error GoTo Fin
    .LookIn = GetDirectory
    .Filename = '*.z'
    If .Execute > 0 Then
        MsgBox .FoundFiles.Count & 'Fichiers ont été trouvés'
        On Error Resume Next
        For I = 1 To .FoundFiles.Count
            Set Wsbk_Temp = Workbooks.OpenText(Filename:=.FoundFiles(I), Origin:= _
            xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
            xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
            Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1))
            Rows('1:3').Delete Shift:=xlUp
            Rows('3:136').Delete Shift:=xlUp
            Rows('4:4').Delete Shift:=xlUp
            Columns('B:D').Delete Shift:=xlToLeft
            ActiveSheet.Range('b1') = ActiveSheet.Name
            Wsht_Calcul.Range('A:C').Value = Range('A:C').Value
            Wsbk_Temp.Close savechanges:=False
            With Wsht_Calcul
                Application.CutCopyMode = True
                .Range('o65536').End(xlUp).Offset(1, 0).Value = .Range('a1').Value
                .Range('o65536').End(xlUp).Offset(0, 1).Value = .Range('b1').Value
                .Range('o65536').End(xlUp).Offset(0, 2).Value = .Range('a2').Value
                .Range('o65536').End(xlUp).Offset(0, 3).Value = .Range('m37').Value
                .Range('o65536').End(xlUp).Offset(0, 4).Value = .Range('n37').Value
            End With
        Next I
    Else
        MsgBox 'Aucun fichier n'a ete trouve'
        Exit Sub
    End If
End With
Wsht_Resultat.Columns('A:E').Sort Key1:=Range('c1'), Order1:=xlDescending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets('Macro').Visible = False
Wsht_Resultat.Select
Range('F1').Select
sPath = Range('F1').Value
If Right(sPath, 1) <> '' Then sPath = sPath & ''
ThisWorkbook.SaveAs sPath & ActiveSheet.Range('G1').Value
Fin:
End Sub
 
Vote positif 0 Vote négatif
merci

le end sub et On Error GoTo fin fonctionne très bien



Yeahou ta macro ne fonctionnait pas j'ai enlevé ce qui est en rouge pour la faire fonctionner cependant le fichoer ne s'enregistre plus à la fin


Set Wsbk_Temp = Workbooks.OpenText(Filename:=.FoundFiles(I), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1)) 🙂

Message édité par: chemist, à: 05/08/2005 13:26

Message édité par: chemist, à: 05/08/2005 13:28
 
Vote positif 0 Vote négatif
Bonjour à tous!

Merci Pascal pour le code que tu proposes à chemist. Ça me sera utile.

Toutefois, j'aurais une autre question. Souvent, je fais des macros en loop. Lorsque je fais une erreur de programmation VBA, il arrive que la macro tourne vraiment en rond sur les mêmes cellules et elle ne se terminer jamais. Je dois donc tout fermer et redémarrer.

Est-il possible d'écrire une condition d'arrêt de la macro advenant que cette dernière, par exemple, repasse une dizaine de fois sur les mêmes cellules? Si oui, peux-tu écrire la programmation que tu emploierais?

Merci de ton temps. 😉
 
Vote positif 0 Vote négatif
Pascal76 écrit:
RE

Personnellement je boucle plus facilement sur du for Next qu'avec du loop cela evite ce genre d'erruer et de boucle infini
Cliquez pour agrandir...

Rebonjour, ou bonsoir...

Je ne connais pas cette fonction. J'ai toujours appris à faire ce genre de truc avec la fonction de loop.

Si je comprends bien, au lieu de mettre :

Do While
[...]
Loop

tu mets :

For
[...]
Next

Est-ce que je comprends bien? Peux-tu m'expliquer la différence entre le loop et le next?

Merci pour tout! 😉
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

M
  • Question Question
XL 2019 La méthode select de la classe range a échoué
Réponses
4
Affichages
69
job75
job75
V
  • Question Question
XL 2016 transformer en boucle une macro créer avec l'enregistreur automatique
Réponses
3
Affichages
70
vazvaz
V
C
  • Résolu(e)
XL 2021 Macro pour mise en page
Réponses
11
Affichages
571
candido57
C
C
  • Question Question
Microsoft 365 Supprimer ligne selon contenu cellule (résolu)
Réponses
7
Affichages
58
job75
job75
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
250
CortoXls
C
ph.vanne
  • Question Question
Autres fenêtre "Publication"
Réponses
10
Affichages
486
ph.vanne
ph.vanne
U
  • Question Question
Autres RÉSOLU ma macro ne fonctionne pas
Réponses
3
Affichages
47
un internaute
U
T
  • Résolu(e)
XL 2019 Filtrer certains champs au démarrage avec vba
2
Réponses
15
Affichages
175
telemarrk
T
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
416
Phil69970
Phil69970
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
334
Gestionnaire_rh
G
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
219
patricktoulon
patricktoulon
M
  • Question Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
305
MBEPID
M
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
362
Oneida
Oneida
B
  • Question Question
XL 2019 Dans une macro de démarrage de fichier masquer le code par des Astérix ou point
Réponses
3
Affichages
92
sylvanu
sylvanu
J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
41
job75
job75
S
  • Résolu(e)
Microsoft 365 VBA Concaténer contenu de plusieurs cellules dans une seule avec séparateurs / évolutifs
Réponses
3
Affichages
114
spike29
S
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
396
patricktoulon
patricktoulon
A
  • Résolu(e)
XL 2016 Recherche d'un mot dans une cellule et surlignage de la ligne
Réponses
4
Affichages
108
Abi23
A
S
  • Résolu(e)
Microsoft 365 Mailing mise en forme HTML : revenir à la ligne automatique si trop de texte saisie
2
Réponses
17
Affichages
204
spike29
S
E
  • Résolu(e)
Microsoft 365 Reduire Temps Execution Code
Réponses
5
Affichages
82
eric72
E
Retour