VBA passer au fichier suivant sans rien faire

B

Batiscaf

XLDnaute Occasionnel
Bonjour à tous,
Grace à ce magnifique forum j'ai trouvé des codes pour constituer cette macro (je remercie les auteurs). Mon problème se situe dans la boucle if then, juste après le else.
Pour résumer, je récupère des données de tous les fichiers xl d'un répertoire pour les compiler dans un autre fichier xl également dans ce répertoire (obligé de le mettre avec les autres !).
Dans la boucle de tous les fichiers, je cherche le code qui dit à VB de passer directement au fichier suivant lorsqu'il arrive au fichier qui porte le même nom que le fichier déjà ouvert.
Merci de votre aide.
Batiscaf.


Sub ARecup_donnees()
Dim recap As Worksheet
Dim txt, r2, r3 As String
Dim cel, r As Range

ChDir ActiveWorkbook.Path 'emplacement du fichier récap

Set recap = ActiveWorkbook.Sheets(1)
fichier = ActiveWorkbook.Name
'recap.Range("A4:L300").Clear
compteur = 4 'puisque ligne 1 à 3 = en-têtes

ChDir ActiveWorkbook.Path 'emplacement du fichier récap
nf = Dir("*.xls*") 'tous les fichiers Excel (dans le répertoire défini + haut)

Application.ScreenUpdating = False

Do While nf <> ""
If nf <> fichier Then
Workbooks.Open Filename:=nf
Workbooks(nf).Sheets(1).Range("C8").Copy Destination:=recap.Range("C" & compteur)
Workbooks(nf).Sheets(1).Range("C14").Copy Destination:=recap.Range("G" & compteur)
Workbooks(nf).Sheets(1).Range("C11").Copy Destination:=recap.Range("I" & compteur)
Workbooks(nf).Sheets(1).Range("C12").Copy Destination:=recap.Range("J" & compteur)
Workbooks(nf).Sheets(1).Range("C13").Copy Destination:=recap.Range("K" & compteur)
Workbooks(nf).Sheets(3).Range("C28").Copy
recap.Range("O" & compteur).PasteSpecial Paste:=xlPasteValues
Workbooks(nf).Sheets(3).Range("C27").Copy
recap.Range("P" & compteur).PasteSpecial Paste:=xlPasteValues
For Each r In Workbooks(nf).Sheets(1).Range("A1:A" & Range("A65536").End(xlUp).Row) '("a1:a10000")
txt = "*VAT applicable*"
If r.Value Like txt Then
r2 = "" & r.Address & ""
r3 = Range(r2).Offset(0, 5).Copy
End If
Next
recap.Range("T" & compteur).PasteSpecial Paste:=xlPasteValues
Workbooks(nf).Sheets(3).Range("C25").Copy
recap.Range("W" & compteur).PasteSpecial Paste:=xlPasteValues
compteur = compteur + 1 'incrémenter lignes dans récap
Workbooks(nf).Close False
nf = Dir
Else
'dire de passer au fichier suivant
compteur = compteur
End If
Loop
Application.ScreenUpdating = True
MsgBox ("Terminé.")
End Sub
 
Trier par date Trier par votes
B

Batiscaf

XLDnaute Occasionnel
Re : VBA passer au fichier suivant sans rien faire

Bonjour kjin,
Désolé mais avec ce filtre la macro ne prend en compte que les fichiers sources situés avant le fichier de compilation dans le répertoire. La macro ne saute pas le fichier de compil pour continuer avec les autres fichiers sources.
Batiscaf
 
Vote positif 0 Vote négatif
K

kjin

XLDnaute Barbatruc
Re : VBA passer au fichier suivant sans rien faire

Bonsoir,
Oui désolé, mal compris la question
Code: 
'...
Do
If nf <> fichier Then
'...
compteur = compteur + 1
End If
nf = Dir
Loop Until nf = ""
'...
Par contre, ta macro me parait plutôt étarnge
A+
kjin
 
Vote positif 0 Vote négatif
K

kjin

XLDnaute Barbatruc
Re : VBA passer au fichier suivant sans rien faire

Re,
La macro qq peu remaniée
Code: 
Sub ARecup_donnees()
Dim wbk1 As Workbook, wbk2 As Workbook, recap As Worksheet
Dim txt As String, c As Range, r As Range

Set wbk1 = ThisWorkbook
With wbk1
    Set recap = .Sheets(1)
    fichier = .Name
End With

ChDir ThisWorkbook.Path 'emplacement du fichier récap
nf = Dir("*.xls*") 'tous les fichiers Excel (dans le répertoire défini + haut)

Application.ScreenUpdating = False

compteur = 4
txt = "VAT applicable"

Do
    If nf <> fichier Then
        Set wkb2 = Workbooks.Open(nf)
        With recap
            .Range("C" & compteur) = Sheets(1).Range("C8")
            .Range("G" & compteur) = Sheets(1).Range("C14")
            .Range("I" & compteur) = Sheets(1).Range("C11")
            .Range("J" & compteur) = Sheets(1).Range("C12")
            .Range("K" & compteur) = Sheets(1).Range("C13")
            .Range("P" & compteur) = Sheets(3).Range("C27")
            .Range("O" & compteur) = Sheets(3).Range("C28")
            .Range("W" & compteur) = Sheets(3).Range("C25")
            Set c = Sheets(1).Range("A1:A" & Range("A65536").End(xlUp).Row)
            Set r = c.Find(txt, lookat:=xlPart)
                If Not r Is Nothing Then .Range("T" & compteur) = r.Offset(0, 5)
        End With
        wkb2.Close False
        compteur = compteur + 1
    End If
    nf = Dir
Loop Until nf = ""

Application.ScreenUpdating = True
MsgBox "Terminé"

End Sub
A+
kjin
 
Vote positif 0 Vote négatif
B

Batiscaf

XLDnaute Occasionnel
Re : VBA passer au fichier suivant sans rien faire

Ok ça fonctionne, merci.
Effectivement ma macro peut paraitre un peu étrange dans sa conception mais n'étant un pro des macros je ne m'inspire que de codes que je comprends et que je peux adapter et recomprendre quelques mois plus tard. Il y avait sans doute plus simple je le conçois.
Je vais maintenant finir les autres données à remonter.
Bonne soirée.
Batiscaf.
 
Vote positif 0 Vote négatif
B

Batiscaf

XLDnaute Occasionnel
Re : VBA passer au fichier suivant sans rien faire

Bonjour kjin,
En effet je n'avais pas vu ton code, je travaillais sur la suite de ma macro.
voici la version finale de ce que j'avais fait et qui fonctionne comme j'ai besoin, tu l'aurais assurement faite en moins de lignes.

Sub ARecup_donnees()
Dim recap As Worksheet
Dim txt, txt2, r2, r3, r4, r5 As String
Dim cel, r As Range

Set recap = ActiveWorkbook.Sheets(1)
fichier = ActiveWorkbook.Name
'recap.Range("A4:L300").Clear
compteur = 4 'puisque ligne 1 à 3 = en-têtes
ChDir ActiveWorkbook.Path 'emplacement du fichier récap
nf = Dir("*.xls*") 'tous les fichiers Excel (dans le répertoire défini + haut)

Application.ScreenUpdating = False
Do
If nf <> fichier Then
Workbooks.Open Filename:=nf
Workbooks(nf).Sheets(1).Range("C8").Copy
recap.Range("C" & compteur).PasteSpecial Paste:=xlPasteValues
Workbooks(nf).Sheets(1).Range("C14").Copy
recap.Range("G" & compteur).PasteSpecial Paste:=xlPasteValues
Workbooks(nf).Sheets(1).Range("C11").Copy Destination:=recap.Range("I" & compteur)
Workbooks(nf).Sheets(1).Range("C12").Copy Destination:=recap.Range("J" & compteur)
Workbooks(nf).Sheets(1).Range("C13").Copy Destination:=recap.Range("K" & compteur)
Workbooks(nf).Sheets(3).Range("C28").Copy
recap.Range("O" & compteur).PasteSpecial Paste:=xlPasteValues
Workbooks(nf).Sheets(3).Range("C27").Copy
recap.Range("P" & compteur).PasteSpecial Paste:=xlPasteValues
recap.Range("S" & compteur).FormulaR1C1 = recap.Range("O" & compteur) - recap.Range("P" & compteur)
recap.Range("Z" & compteur).FormulaR1C1 = "=RC[-11]-RC[-1]" 'controle des écarts de totaux ht
recap.Range("A" & compteur & ":X" & compteur).Interior.ColorIndex = xlNone
For Each r In Workbooks(nf).Sheets(1).Range("A" & Range("A65536").End(xlUp).Row - 4 & ":A" & Range("A65536").End(xlUp).Row) '("a1:a10000")
'txt = "Grand Total Event"
If r.Value Like "Grand Total Event" Then
r2 = Range("" & r.Address & "").Offset(0, 5).Copy
recap.Range("Y" & compteur).PasteSpecial Paste:=xlPasteValues
Exit For
Else
recap.Range("Y" & compteur) = "LM"
End If
Next
For Each r In Workbooks(nf).Sheets(1).Range("A" & Range("A65536").End(xlUp).Row - 2 & ":A" & Range("A65536").End(xlUp).Row) '("a1:a10000")
'txt2 = "*VAT applicable*"
If r.Value Like "*VAT applicable*" Then
r4 = Range("" & r.Address & "").Offset(0, 5).Copy
recap.Range("T" & compteur).PasteSpecial Paste:=xlPasteValues
Exit For
Else
recap.Range("T" & compteur) = "No VAT"
End If
Next
Workbooks(nf).Sheets(3).Range("C25").Copy
recap.Range("W" & compteur).PasteSpecial Paste:=xlPasteValues
compteur = compteur + 1 'incrémenter lignes dans récap
Workbooks(nf).Close False
End If
nf = Dir
Loop Until nf = ""
Application.ScreenUpdating = True

MsgBox ("Terminé.")
End Sub

Bonne journée.
Batiscaf
 
Vote positif 0 Vote négatif

Discussions similaires

Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
253
Zonmé
Z
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
105
farid
F
Usine à gaz
  • Résolu(e)
XL 2021 Ecrire dans une une autre feuille
Réponses
3
Affichages
316
Usine à gaz
Usine à gaz
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
366
M@xu3L
M
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
A
  • Question
Microsoft 365 Cpier/coller en VBA
Réponses
7
Affichages
435
A-F
A
T
  • Question
XL 2016 Créer un renvoi automatique vers une feuille récap
Réponses
2
Affichages
646
thsoulard
T
P
  • Résolu(e)
XL 2016 4 étapes en 1 seule Excel vba
Réponses
4
Affichages
469
Pygos691
P
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
232
guiyom
G
O
  • Question
XL 2010 suppression fichiers excel vba
Réponses
9
Affichages
386
Oneida
Oneida

Membres actuellement en ligne

10 membres et 86 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 321
Messages
2 087 260
Membres
103 498
dernier inscrit
FAHDE