Sub Zomaplus() 'By Mr Zomaplus
Dim Curcalc As XlCalculation
Dim Ws, Ws2 As Worksheet
Dim Chemin As String, Fichier As String
Application.ScreenUpdating = False
Curcalc = Application.Calculation
Application.Calculation = xlCalculationManual
'Définit le répertoire contenant les fichiers
'On Error GoTo std_errhandler
If Sheets("Menu").Range("B7").Value = "" Then
Chemin = Browseforfolder()
Sheets("Menu").Range("B7") = Chemin
Else
Chemin = Sheets("Menu").Range("B7").Value
End If
If Chemin = "" Then Exit Sub
'Boucle sur tous les fichiers rep du répertoire.
Fichier = Dir(Chemin & "\*.rep")
If Fichier = "" Then MsgBox "Aucun fichier de type .rep dans le répertoire sélectionné"
Do While Len(Fichier) > 0
'Debug.Print Chemin & Fichier
Application.StatusBar = "Traitement en cours : " & Fichier
'On vérifie qu'il n'y ait pas de feuille déjà ayant pour nom le même que celui que l'on veut lui donner
For Each Ws2 In ThisWorkbook.Sheets
If Ws2.Name = Mid(Fichier, 10, 5) Then
MsgBox ("Une feuille existe déjà avec pour nom : " & Ws2.Name & vbCrLf & "Merci de bien vouloir la supprimer ou la renommer")
Exit Sub
End If
Next Ws2
Set Ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Ws.Name = Mid(Fichier, 10, 5)
'Contient l'ensemble des opérations à effectuer sur le fichier spécifié
Call Execution(Chemin & "\" & Fichier, Ws)
Fichier = Dir()
Loop
Set Ws = Nothing
Set Ws2 = Nothing
Sheets("Menu").Select
Application.Calculation = Curcalc
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
std_errhandler:
MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
Application.Calculation = Curcalc
Application.ScreenUpdating = True
End Sub
Sub Execution(repertoire_source As String, ByVal Cible As Worksheet)
Dim Max_ligne As Long
Dim last_source_line As Long
Dim B, Str As String
Dim Lignes_a_suppr As Collection
Dim L As Variant
Dim i&, Sh As Worksheet, ShDest As Worksheet, Liste$
'Import du fichier
Call copie(Cible, repertoire_source)
'Split en colonnes
Call Split(Cible)
Set source = Sheets("Source")
'Suppression des colonnes B,E,F,I,J,K
Cible.Columns("k:k").Delete Shift:=xlToLeft
Cible.Columns("j:j").Delete Shift:=xlToLeft
Cible.Columns("i:i").Delete Shift:=xlToLeft
Cible.Columns("f:f").Delete Shift:=xlToLeft
Cible.Columns("e:e").Delete Shift:=xlToLeft
Cible.Columns("b:b").Delete Shift:=xlToLeft
'Suppression des lignes pour lesquelles la cellule B est de longueur inférieure à 6
'Les lignes sont d'abord stockées dans une collection, afin de ne pas perturber la boucle
'Puis tous les membres de la collection sont supprimés
Max_ligne = Cible.UsedRange.Rows.Count
Set Lignes_a_suppr = New Collection
For i = 1 To Max_ligne
Str = Cible.Cells(i, 2).Value
Str = Replace(Str, " ", "")
If Len(Str) < 6 Or Str = "------" Then 'la condition 6 tirets n'est pas dans le cahier des charges mais elle m'a paru évidente
Lignes_a_suppr.Add Cible.Cells(i, 2).EntireRow
End If
Next i
For Each L In Lignes_a_suppr
L.Delete
Next L
Set Lignes_a_suppr = Nothing
'Insertion d'une ligne
Cible.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'Titres des colonnes
Cible.Cells(1, 1).Formula = "Code Agence"
Cible.Cells(1, 2).Formula = "RC"
Cible.Cells(1, 3).Formula = "Libellé"
Cible.Cells(1, 4).Formula = "Montant"
Cible.Cells(1, 5).Formula = "Nbre"
'Inscription du nom de la feuille en colonne A si b non vide, ou b rempli de blancs
For i = 2 To Max_ligne
If Replace(Cible.Cells(i, 2).Value, " ", "") <> "" Then
Cible.Cells(i, 1).Value = Cible.Name
End If
Next i
'Suppression des .00 et des virgules
Cible.Range("D:E").Replace What:=".00", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cible.Range("D:E").Replace What:=",", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Copie des lignes correspondant à certains critères
Liste = ",202212,202213,202217,202218,202221,202223,202224,202225,202229,203102,203104,203105,203106,203107,203108,203109,203112,203113,203114,203116,203118,203119,204102,204106,204108,204109,204110,204115,251120,251121,251122,251123,251125,251130,251131,251132,251133,251134,251135,251140,251170,251171,251172,251173,251174,251175,251195,252101,252102,252111,252112,253110,253111,253115,253116,253118,253210,253216,253310,253900,"
Set ShDest = Sheets("SOURCE")
Application.ScreenUpdating = False
ShDest.UsedRange.ClearContents
For Each Sh In Worksheets
If Sh.Name <> ShDest.Name And Sh.Visible = True Then
For i = 1 To Sh.Cells(Sh.Rows.Count, 1).End(3).Row
If InStr(Liste, "," & Sh.Cells(i, 2) & ",") > 0 Then
Sh.Cells(i, 1).Resize(, 5).Copy ShDest.Cells(ShDest.Rows.Count, 1).End(3)(2)
End If
Next i
End If
Next Sh
End Sub