boucle traitement plusieurs fichiers userform

[krafft]

Ai 1 fichier vierge d'où je lance une macro (consolidator.xls)
Ai 80 fichiers (3 uniquement dans mon exemple) dans un répertoire, ayant la même structure, les memes onglets (janvier, fevrier, mars,...)

1/ Souhaite automatiser le copier-coller (seulement les valeurs) d'une plage de données fixe (ex: A1:L11) de chacun des 80 fichiers du même onglet (par exemple, uniquement les onglets nommés janvier) dans le fichier vierge, et ce, mis bout à bout.

2/ Aimerais pouvoir configurer l'onglet sur lequel se fait le traitement, comme une variable que l'utilisateur choisit (cf. liste deroulante de mon user form) qui s'affiche à l'ouverture de consolidator.xls)

3/ Aimerais pouvoir sélectionner le répertoire dans lequel se fait le traitement et contenant tous les fichiers Excel (les 80 fichiers) (cf. mon user form à l'ouverture du classeur)

nb : ai réalisé une macro qui fonctionne (ouvrir consolidator.xls dans module1), mais sans aucune boucle (il y aurait donc 80 fois le code "ouvrir fichier, faire le traitement, ...", et ce pour chacun des onglets (Janvier, Fevrier, Mars...).

La voici intégralement:

Sub test()
'
' test Macro
' Macro enregistrée le 13/11/2007 par Francois Krafft
'
Workbooks.Open Filename:="C:\Data\fkrafft\Bureau\test macro III\caisse1.xls"
Worksheets("JANVIER").Select
Range("A1:L11").Select
Selection.Copy
Windows("Consolidator.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("caisse1.xls").Activate
ActiveWindow.Close

Workbooks.Open Filename:="C:\Data\fkrafft\Bureau\test macro III\caisse2.xls"
Worksheets("JANVIER").Select
Range("A1:L11").Select
Selection.Copy
Windows("Consolidator.xls").Activate
Range("A12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("caisse2.xls").Activate
ActiveWindow.Close

Workbooks.Open Filename:="C:\Data\fkrafft\Bureau\test macro III\caisse3.xls"
Worksheets("JANVIER").Select
Range("A1:L11").Select
Selection.Copy
Windows("Consolidator.xls").Activate
Range("A23").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("caisse3.xls").Activate
ActiveWindow.Close

End Sub

nb2: le bouton de ma macro est l'unique bouton gris dans le classeur.
nb3: il faudra fermer l'user form qui s'affiche à l'ouverture.
nb4: il faut aussi aller dans VBA (Alt+F11) afin de modifier le code de l'emplacement des fichiers sur votre ordinateur (C:\Desktop\...)

N'hésitez pas à me poser des questions de cadrage..

En vous remerciant bcp par avance..
Francois

 

[krafft]

Re : boucle traitement plusieurs fichiers userform

OK, c'est tout bon. Sujet résolu. Je vous mettrai le code, et sa description pas-à-pas et les fichiers en pièce jointe.

 

[krafft]

Re : boucle traitement plusieurs fichiers userform

Comme promis, voici le code et les fichiers en pièce jointe :
1. Petty Cash Consolidator (le fichier à partir duquel vous executez la macro
2. 3 fichiers exemples au format d'une table à consolider, à mettre ds 1 répertoire unique.

Je vous copie-colle le code ci-dessous :

Option Explicit

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

Private Const BIF_RETURNONLYFSDIRS = &H1

Public Function VoirDossier(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
Dim hWndAccessApp

Dim BIF_RETURNONLYFSDIRS

With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With

dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

If X Then
wPos = InStr(szPath, Chr(0))
VoirDossier = Left$(szPath, wPos - 1)
Sheets("ListeDeroulante").Select
ActiveSheet.Cells(1, 2) = VoirDossier
Else
VoirDossier = ""
End If
End Function
Private Sub CommandButton1_Click()
Call VoirDossier("c:\")

Dim fs As FileSearch
Dim dossier As String
Dim i As Integer
On Error Resume Next
Set fs = Application.FileSearch
dossier = ActiveSheet.Cells(1, 2)
With fs
.NewSearch
.Filename = "*.xls"
.LookIn = dossier
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For i = 1 To .Count
Me.ListBox1.AddItem Dir(.Item(i))
Next i
End With
Else
MsgBox "Aucun classeur trouvés " & _
"dans le dossier '" & dossier & "'."
Me.ListBox1.AddItem "Aucun classeur !"
End If
End With
Set fs = Nothing

End Sub
Private Sub CommandButton2_Click()

'Renvoi à un message d'erreur en cas d'erreur
'On Error GoTo Fin

'Déclaration des variables
Dim rep_appli, i, j
Dim xl As Object
Dim fs, rep, dossier, f
Dim ws As String
Set fs = CreateObject("Scripting.FileSystemObject")
rep = Range("ListeDeroulante!B1")
Set dossier = fs.GetFolder(rep)
Set xl = CreateObject("Excel.Application")
ws = ComboBox1.Value

'Traitement en boucle des fichiers contenus dans le répertoire
For Each f In dossier.Files

'Vérification de la présence des fichiers excel dans le répertoire
If Right(f.Name, 3) = "xls" Then
'Ouverture du fichier Excel
Workbooks.Open Filename:=dossier & "\" & f.Name

'Sélection du worksheet "JANVIER"
Worksheets(ws).Activate
'Sélection de la plage à copier
Range("A1:L11").Select
'Copie de la plage sélectionnée
Selection.Copy
'Activation du workbook "consolidator.xls" et du worksheet "ConsolidatedData"
Workbooks("Petty Cash Consolidator.xls").Worksheets("ConsolidatedData").Activate
'Sélection de la cellule A1
Range("A1").Select
If ActiveCell.Value = 0 Then
'Collage spécial seulement les valeurs
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Else
'Fonction Fin+Maj+Flèche Bas
Selection.End(xlDown).Select
'Sélection de la cellule en-dessous de la dernière cellule sélectionnée
ActiveCell.Offset(1, 0).Select
'Collage spécial seulement les valeurs
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End If
Else
'Message d'erreur si aucun fichier Excel n'est recensé dans le répertoire sélectionné
MsgBox "Il n'y a aucun fichier Excel (.xls) dans le répertoire sélectionné" & vbCrLf _
, vbCritical
End If
Application.CutCopyMode = False
Windows(f.Name).Close

Next f
Range("A1").Select
'Message d'information pour indiquer que la consolidation des fichiers est terminée.
MsgBox "Consolidation terminée."

'Message d'erreur en cas d'erreur demandant à l'utilisateur de fermer tous les fichiers excel en cours
Fin:
If Err.Number <> 0 Then
MsgBox "Impossible d'exéctuer le programme !" & vbCrLf _
& "Assurez-vous qu'aucun autre fichier Excel ne soit ouvert !" & vbCrLf _
, vbCritical
End If

End Sub