Hello le forum !
J'ai besoin d'un petit coup de main si possible
Alors voilà j'ai le code suivant :
Celui ci me permet de compiler plein de fichier de ce type la :
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 !
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 FunctionCelui ci me permet de compiler plein de fichier de ce type la :
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 !
