1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
| Sub Copie_Debits()
'==========================================
'= Procédure de sélection d'un répertoire =
'= Utilise le scripting object =
'==========================================
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
Range("CheminDebit") = vrtSelectedItem
Next vrtSelectedItem
End If
End With
Set fd = Nothing
'========================
'= Procédure principale =
'========================
'# Déclaration des variables de la procédure
Dim oFso As Object
Dim oFile As Object
Dim oDirectory As Object
Dim wkbMain As Workbook
Dim wkbPAT As Workbook
Dim wks As Worksheet
Dim Debits As Worksheet
Dim MaxLg As Long 'Mesure de la longueur des colonnes copiées
Dim i As Long 'Compteur pour décalage des colonnes
Dim Col As String 'Incrément sur les colonnes
'# Création des objets de scripting
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oDirectory = oFso.getfolder(Range("CheminDebit"))
'# Affectation de la variable wkbMain au classeur accueillant les données
Set wkbMain = ThisWorkbook
Set Debits = Worksheets("DEBITS")
'# On active la gestion d'erreur
'On Error GoTo GestionErreur
'# On vérifie qu'il y a bien des fichiers dans le répertoire
If Not (oDirectory.Files.Count > 0) Then
MsgBox "Le répertoire sélectionné ne contient aucun fichier !", vbCritical + vbOKOnly, "Erreur répertoire"
Exit Sub
End If
'# Effacement préalable de la plage de données
Debits.Range("A:Z").CurrentRegion.Clear
'# Désactivation de certains paramètres pour accélerer le traitement
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'# Mise a 1 de la valeur du compteur et initialisation du calcul
i = 1
Col = Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1)
'# On parcours tous les fichiers du répertoire
For Each oFile In oDirectory.Files
'# Si le fichier est un fichier Excel on l'ouvre.
If Right(oFile.Name, 4) = ".XLS" Then
Workbooks.Open Range("CheminDebit") & "\" & oFile.Name, 0 '<- 0: ne pas mettre à jour les liens externes.
Set wkbPAT = ActiveWorkbook
'# On parcours les onglets du fichier.
For Each wks In wkbPAT.Worksheets
'"Mesure de la lognueur de la Colonne
'#Pour ce faire il faut combler les vides
wks.Cells(5, 1) = "XXX"
MaxLg = wks.Range("A1").End(xlDown).Row
'Nettoyage du comblement des vises
wks.Cells(5, 1).ClearContents
'# On copie les infos récupérées dans la feuile débits
wks.Range(Cells(1, 1), Cells(MaxLg, 2)).Copy (Sheets("DEBITS").Range(Cells(1, i), Cells(MaxLg, i + 1)))
i = i + 2
Col = Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1)
Next
End If
'# On ferme le fichier après récupération
wkbPAT.Close SaveChanges:=False
Next
GestionErreur:
'# On ferme les objets créés
Set oFso = Nothing
Set oDirectory = Nothing
Set wkbPAT = Nothing
Set wkbMain = Nothing
'# Rétablissement des paramètres Excel
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "Les données des fichiers ont été importées avec succès."
End Sub |
Partager