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
|
Sub Fiche_def()
'Init Variable
Dim i As Integer
i = 1
Dim cell As String
Dim ligne_debut As Integer
Dim ligne_fin As Integer
Dim FichierCelStr As String
Dim NomFiche As String
'Sélection fichier exportation rbase
FichierCelStr = Application.GetOpenFilename("Excel (*.xls), *.xls", 1, "Sélectionner le Fichier d'Exportation de Rbase pour les Fiches de Défauts")
Workbooks.Open (FichierCelStr)
'Mise en forme
Columns("A:D").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'Copy ver Model
Sheets("fiche_def").Select
Sheets("fiche_def").Move After:=Workbooks("MODELEv1.2.xls").Sheets(1)
'var active model
Set model = Worksheets("model")
'variable fichier
Dim Chemin As String
Dim NomFichier As String
Chemin = ActiveWorkbook.Path
'init var pour boucle
ligne_debut = 1
ligne_fin = 0
Sheets("fiche_def").Select
While ligne_fin < 8000
'Traitement copy cellule exporte Rbase
ligne_debut = ligne_debut
ligne_fin = ligne_debut + 23
Sheets("fiche_def").Select
cell = "A" & CStr(ligne_debut) & ":" & "F" & CStr(ligne_fin)
If Sheets("fiche_def").Cells(ligne_debut, 1) = "" Then
GoTo fin:
End If
Range(cell).Select
Application.CutCopyMode = False
Selection.Copy
'Traitement colle cellule model fiche défaut
Sheets("model").Select
Range("A1:F1").Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
'Enregistrement fichier
model.Select
model.Copy
NomFichier = Chemin & "\" & model.Cells(1, 1) & ".xls"
NomFiche = model.Cells(1, 1).Value 'Ajout Nomde la faiche dans l'onglet
Sheets("model").Name = NomFiche 'Ajout Nomde la faiche dans l'onglet
ActiveWorkbook.SaveAs Filename:=NomFichier, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close
ligne_debut = ligne_debut + 25
Wend
fin:
'Boite de dialogue
Dim result As Integer
result = MsgBox("Voici le chemin de vos fichiers créé" & Chemin, vbOKOnly, "Informations")
If result = 1 Then
Shell "C:\windows\explorer.exe " & Chemin, vbMaximizedFocus
End If
ActiveWorkbook.Close saveChanges:=False
ActiveWorkbook.Close saveChanges:=False
End Sub |
Partager