Faire arrêter une macro

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:D').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
PascalXLD

PascalXLD

XLDnaute Barbatruc
Modérateur
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:D').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
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
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
C

chemist

XLDnaute Junior
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
B

bencourriel

XLDnaute Occasionnel
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
B

bencourriel

XLDnaute Occasionnel
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

Discussions similaires

B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
217
Compte Supprimé 979
C
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
936
thivame
T
M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
111
marie3107
M
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
250
Zonmé
Z
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
194
Francky79
F
G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
216
gui22
G
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
279
robpellan52
R
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
243
phoceenjo
P
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
350
dadu35
D
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
158
marie3107
M

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 38 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 294
Messages
2 086 895
Membres
103 404
dernier inscrit
sultan87