Sub extraction()
'Extraction des "voitures"
Sheets("voitures").Activate
Sheets("voitures").Select
WB = ThisWorkbook.Name
WP = ThisWorkbook.Path
WS = ActiveSheet.Name
Application.DisplayAlerts = False
' Boucle de la ligne 1 à la dernière en colonne B
For lgLig = 2 To Range("B" & Cells.Rows.Count).End(xlUp).Row
Workbooks(WB).Activate
With Workbooks(WB).Worksheets(WS)
' Nom du fichier à traiter
NumVoiture = Range("B" & lgLig).Value
strNomFic = WP & "\" & NumVoiture & "_C015_Fichier_Enrichissement.xls"
NomFic = NumVoiture & "_C015_Fichier_Enrichissement.xls"
' Si le fichier est trouvé, l'ouvrir sinon le créer
If Dir(strNomFic) = "" Then
' Créer un classeur
Workbooks.Add
' Importer les onglets modèles
Workbooks(WB).Sheets("voitures (M)").Copy After:=ActiveWorkbook.Sheets(1)
'Renomme onglet
Workbooks(NomFic).Sheets("voitures (M)").Name = "voitures"
'Supprimer les onglets
Worksheets("Feuil1").Delete
Worksheets("Feuil2").Delete
Worksheets("Feuil3").Delete
' Copier les colonnes A et B dans le nouveau classeur
Workbooks(WB).Sheets("voitures").Range("A" & lgLig & ":B" & lgLig).Copy
Workbooks(NomFic).Sheets("voitures").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Sauvegarder le nouveau classeur
Workbooks(NomFic).SaveAs strNomFic
Else
' Ouvrir le classeur
If VerifOuvertureClasseur(strNomFic) Then
' Récupérer la dernière ligne en colonne A
lgDerLig = Workbooks(NomFic).Sheets("voitures").Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
' Copier les colonnes A => B dans le classeur
Workbooks(WB).Sheets("voitures").Range("A" & lgLig & ":B" & lgLig).Copy
Workbooks(NomFic).Sheets("voitures").Range("A" & lgDerLig).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Workbooks.Open strNomFic
' Récupérer la dernière ligne en colonne A
lgDerLig = Workbooks(NomFic).Sheets("voitures").Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
' Copier les colonnes A => AX dans le classeur
Workbooks(WB).Sheets("voitures").Range("A" & lgLig & ":B" & lgLig).Copy
Workbooks(NomFic).Sheets("voitures").Range("A" & lgDerLig).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End If
End With
Next lgLig
' Sauvegarder/Fermer le classeur
For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then
If InStr(w.Name, "voitures") > 0 Then
w.Close savechanges:=True
End If
End If
Next w
End Sub