Sub Recupere()
' Demande si tous les fichiers sont fermés
If MsgBox("Avez vous des fichiers de budget ouverts?", vbYesNo, "Demande de confirmation") = vbYes Then
MsgBox ("Veuiller fermer les fichiers concernés et relancer le traitement." & "Traitement annulé.")
Exit Sub
End If
' Ouverture du chemin d'accès aux fichiers
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim T1, T2, T3(), Indice As Integer, J As Long, I As Integer
Feuil4.Cells.ClearContents
Application.ScreenUpdating = False
Set Ws = Sheets("Base")
Ws.Columns("A:E").Clear
Ws.Range("A1:E1") = Array("numsocieté", "numcode", "Libellé", "mois", "montant")
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path & "\"
Fichier = Dir(Chemin & "*.xlsx")
' vérification que des fichiers ne sont pas ouverts
If VerifOuvertureClasseur(Fichier) Then
MsgBox ("Des fichiers sont ouverts, merci de bien vouloir les fermer et de relancer le traitement.")
Exit Sub
End If
'début de la boucle
Do While Fichier <> ""
If Fichier <> ThisWorkbook.Name Then
If InStr(1, Fichier, "EHPAD", vbTextCompare) > 0 Then
With Sheets("MODELE EHPAD")
T1 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
ElseIf InStr(1, Fichier, "CLINEA", vbTextCompare) > 0 Then
With Sheets("MODELE CLINEA")
T1 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
Else
Erase T1
MsgBox "Type de fichier inconnu"
End If
If IsArray(T1) Then
With Workbooks.Open(Chemin & Fichier)
With .Sheets(1)
T2 = .Range("A1:O" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
.Close savechanges:=False
End With
Indice = 0: Erase T3
For J = 1 To UBound(T1)
If T1(J, 2) <> "" Then
For I = 1 To 12
If T2(T1(J, 3), 2 + I) <> 0 Then ' Montant différent de 0
Indice = Indice + 1
ReDim Preserve T3(1 To 5, 1 To Indice)
Ws.Columns("A").NumberFormat = "@"
T3(1, Indice) = "0" & (Split(T2(3, 3), "/")(0)) ' Numéro de société
T3(2, Indice) = T1(J, 1) ' Numéro de code
T3(3, Indice) = T1(J, 2) ' Libellé
T3(4, Indice) = MonthName(I) ' Le mois
T3(5, Indice) = (T2(T1(J, 3), 2 + I)) * 1000 ' Montant
End If
Next I
End If
Next J
Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T3, 2), UBound(T3)) = Application.Transpose(T3)
End If
End If
Fichier = Dir()
Loop
Ws.Columns("A:E").AutoFit
Ws.Columns("E").NumberFormat = "#,##0.0"
MsgBox ("traitement terminé")
End Sub
Function VerifOuvertureClasseur(Fichier As String) As Boolean
Dim n As Integer
On Error Resume Next
n = FreeFile()
Open Fichier For Input Lock Read As #n
Close n
If Err.Number = 0 Then VerifOuvertureClasseur = False
If Err.Number = 70 Then VerifOuvertureClasseur = True
On Error GoTo 0
End Function