petit problème sur une macro Excel

fumexo

Membre confirmé
9 Mai 2017
16
0
28
Hello le forum !

J'ai besoin d'un petit coup de main si possible :)

Alors voilà j'ai le code suivant :
Bloc de code:
Option Explicit
    Dim MonRepertoire As String, onglet As String, autofin As Boolean, lignedeb As String, lignefin As String, coldeb As String, colfin As String, destinataire, i As Integer, dimTab As Integer, depuis As Integer
    Dim TabEnTete() As String
Sub select_repertoire()
    Dim Repertoire As String
   
    Dim CodeScript As String, CR As String
CR = Chr$(13)
CodeScript = "tell application ""Finder"""
CodeScript = CodeScript & CR & "set chemin to choose folder with prompt ""Sélectionnez le dossier à traiter"""
CodeScript = CodeScript & CR & "set chemin to chemin as string"
CodeScript = CodeScript & CR & "end tell"
Repertoire = MacScript(CodeScript)
    If Repertoire <> "" Then
        Range("repertoire").Value = Repertoire
    End If
End Sub
Sub compiler()
Application.ScreenUpdating = False
    ' mise en place des paramètres du programme
    MonRepertoire = Range("repertoire").Value

    Set destinataire = ActiveWorkbook
   
    coldeb = Range("coldeb").Value
    colfin = Range("colfin").Value
    lignedeb = Range("lignedeb").Value
    lignefin = Range("lignefin").Value
    onglet = Range("onglet").Value
    autofin = False
    If lignefin = "" Then autofin = True
    dimTab = 0
   
    If Range("debentete").Value <> "" Then
        dimTab = (Cells(Range("debentete").Row, Range("debentete").Column - 1).End(xlToRight).Column - Range("debentete").Column + 1)
        ReDim TabEnTete(dimTab - 1)
        For i = 0 To UBound(TabEnTete)
            TabEnTete(i) = Cells(Range("debentete").Row, Range("debentete").Column + i).Value
        Next i
    End If
       
    ' effacement des données
   
    Sheets("compilation").Activate
    Range("A2").CurrentRegion.Select
    Selection.Clear
   

    ' place le curseur au début
    Range("A2").Offset(0, dimTab).Select
    depuis = ActiveCell.Row
   
    ' lecture du répertoire
    MsgBox "Début de la compilation ..."
    ListeFichiers MonRepertoire
    MsgBox "Fin de la compilation ..."
    Application.ScreenUpdating = True
End Sub
Sub ListeFichiers(Repertoire As String)
   
    If Repertoire = "" Then
        MsgBox " Choisissez le répertoire !"
        Exit Sub
    End If
    Dim lefichier As String, lechemin As String
   
    lechemin = Repertoire
    Dim CodeScript As String, CR As String, gu As String, chemin As String
CR = Chr$(13)
gu = Chr$(34)
CodeScript = CodeScript & CR & "tell application""finder"""
CodeScript = CodeScript & CR & "set chemin to " & gu & Repertoire & gu
CodeScript = CodeScript & CR & "end tell"

CodeScript = CodeScript & CR & "set un_dossier to chemin"

CodeScript = CodeScript & CR & "set un_dossier to chemin as alias"

CodeScript = CodeScript & CR & "tell application ""Finder"""
CodeScript = CodeScript & CR & "set i to 1"
CodeScript = CodeScript & CR & "set les_fichiers to files of un_dossier"
CodeScript = CodeScript & CR & "repeat with chaque_fichier in les_fichiers"

CodeScript = CodeScript & CR & "set nom to name of chaque_fichier"
CodeScript = CodeScript & CR & "set extens to document file nom in un_dossier"
CodeScript = CodeScript & CR & "set lextension to name extension of extens"
CodeScript = CodeScript & CR & "set lechemin to un_dossier as string"
CodeScript = CodeScript & CR & "if lextension = ""xlsx"" or lextension = ""xlsm"" or lextension = ""xls"" then"
CodeScript = CodeScript & CR & "tell application ""Microsoft Excel"""
CodeScript = CodeScript & CR & "activate (select sheet ""compilation"")"
CodeScript = CodeScript & CR & "set value of cell (""L"" & i) to lechemin"
CodeScript = CodeScript & CR & "set value of cell (""M"" & i) to nom"
CodeScript = CodeScript & CR & "end tell"
CodeScript = CodeScript & CR & "set i to i + 1"
CodeScript = CodeScript & CR & "end if"

CodeScript = CodeScript & CR & "end repeat"
CodeScript = CodeScript & CR & "set les_dossiers to folders of un_dossier"
CodeScript = CodeScript & CR & "repeat with chaque_dossier in les_dossiers"
CodeScript = CodeScript & CR & "set un_dossier to Chaque_dossier"

CodeScript = CodeScript & CR & "set les_fichiers to files of un_dossier"
CodeScript = CodeScript & CR & "repeat with chaque_fichier in les_fichiers"
CodeScript = CodeScript & CR & "set nom to name of chaque_fichier"
CodeScript = CodeScript & CR & "set extens to document file nom in un_dossier"
CodeScript = CodeScript & CR & "set lextension to name extension of extens"
CodeScript = CodeScript & CR & "set lechemin to un_dossier as string"
CodeScript = CodeScript & CR & "if lextension = ""xlsx"" or lextension = ""xlsm"" or lextension = ""xls"" then"
CodeScript = CodeScript & CR & "tell application ""Microsoft Excel"""
CodeScript = CodeScript & CR & "activate (select sheet ""compilation"")"
CodeScript = CodeScript & CR & "set value of cell (""L"" & i) to lechemin"
CodeScript = CodeScript & CR & "set value of cell (""M"" & i) to nom"
CodeScript = CodeScript & CR & "end tell"
CodeScript = CodeScript & CR & "set i to i + 1"
CodeScript = CodeScript & CR & "end if"
CodeScript = CodeScript & CR & "end repeat"
CodeScript = CodeScript & CR & "end repeat"
CodeScript = CodeScript & CR & "end tell"
MacScript (CodeScript)
   
    i = 1
    Do While i > 0
    Worksheets("compilation").Activate
        lechemin = Range("L" & i)
        lefichier = Range("M" & i)
       
        If lefichier <> "" Then
    ' boucle sur tous les fichiers du répertoire
            If Left(lefichier, 2) <> "~$" Then
           
               
                Workbooks.Open Filename:=lechemin & lefichier
                If FeuilleExiste(onglet) Then
                    Sheets(onglet).Select
                   
               
               
                    ' trouve la dernière ligne
                    Range(coldeb & (lignedeb - 1)).End(xlDown).Select
                    If autofin Then lignefin = ActiveCell.Row

                    ' sélectionne la région à copier
                    Range(coldeb & lignedeb & ":" & colfin & lignefin).Select

                    ' copie la région
                    Selection.Copy

                    ' change de fichier
                    destinataire.Activate
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Application.CutCopyMode = False
                   
                   

                    If Range("debentete").Value <> "" Then
                        For i = 1 To UBound(TabEnTete)
                            Workbooks(lechemin & lefichier).Activate
                            Range(TabEnTete(i)).Copy
                            destinataire.Activate
                            Range("A" & depuis & ":" & "A" & (depuis + lignefin - lignedeb)).Offset(0, i).Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                            Application.CutCopyMode = False
                        Next i
                    End If
                   

                If Range("pasapas").Value = "OUI" Then
                   MsgBox ("Fin de recopie de """ & lefichier & """ : " & lignefin - lignedeb + 1 & " lignes recopiées !")
                End If
                   
                End If

                ' ferme le fichier sans faire de changement
               Workbooks(lefichier).Activate
                ActiveWindow.Close False
               
                ' place le curseur sous les données
                destinataire.Activate
                Cells(depuis + lignefin - lignedeb + 1, dimTab + 1).Select
                ' sauvegarde cette ligne pour recopie des en-têtes en colonne
                depuis = ActiveCell.Row
               
               

                    Else
                        MsgBox "La feuille """ & onglet & """ du fichier """ & lefichier & """ est nouvelle et ne sera pas reprise !"
                    End If
        Else
        Range("L" & ":M").Select
                Selection.Clear
        Exit Sub
        End If
        i = i + 1
        Loop
    
End Sub
Function FeuilleExiste(NomFeuille As String) As Boolean
    On Error GoTo Err_FeuilleExiste
    FeuilleExiste = False
    FeuilleExiste = Not ActiveWorkbook.Worksheets(NomFeuille) Is Nothing
Err_FeuilleExiste:
End Function

Celui ci me permet de compiler plein de fichier de ce type la :
Capture d’écran 2017-06-12 à 14.22.10.webp

en un seul, ce qui est très pratique.

Mais le problème c'est qu'il ne prend que la première ligne, dans l'exemple ci dessus, uniquement la ligne:
oli 10 2017 L Préparation du sol 11
et passe au fichier suivant
Et la je bloque, je n'arrive pas à comprendre pourquoi est ce qu'il fait cela, une idée ? :)

Merci d'avance !
 
Si quelqu'un veut bien m'aider, le problème est toujours d'actualité et je ne sais pas coder en applescript donc c'est peut être tout simple ! :p