Ce forum est en partie financé par l’affichage de publicités. Merci de désactiver votre bloqueur de publicités pour nous permettre de continuer à fournir ce service.
  1. Ce site utilise des cookies. En continuant à utiliser ce site, vous acceptez l'utilisation des cookies. En savoir plus.

petit problème sur une macro Excel

Discussion dans 'Développement Mac' créé par fumexo, 12 Juin 2017.

Mots-clefs:
  1. fumexo

    fumexo Membre Junior

    Inscrit:
    9 Mai 2017
    Messages:
    16
    J'aime reçus:
    0
    Hello le forum !

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

    Alors voilà j'ai le code suivant :
    Code (Text):
    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.png

    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 !
     
  2. fumexo

    fumexo Membre Junior

    Inscrit:
    9 Mai 2017
    Messages:
    16
    J'aime reçus:
    0
    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
     
  3. fumexo

    fumexo Membre Junior

    Inscrit:
    9 Mai 2017
    Messages:
    16
    J'aime reçus:
    0
    C'est bon j'ai réussi merci de votre aide ...
     
  4. Nimitz

    Nimitz Nouveau Membre

    Inscrit:
    20 Septembre 2017
    Messages:
    9
    J'aime reçus:
    0
    D'accord même si personne ne ta aider
     

Partager cette page

Chargement...

iOccasion - Achetez un produit Apple d'occasion

refurb Apple