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
|
Private Sub BtCréerFichier_Click()
Dim i As Integer
Dim fich As String, dep As String
Dim Cel As Range
Dim Depart As Long
Dim FName As String
Dim VBComp
Application.ScreenUpdating = False
FName = BrowseFolder("Select A Folder")
If Dir(FName, vbDirectory) <> vbNullString Then
For i = 0 To Listbox1.ListCount - 1
Set Cel = Sheets(1).Columns("B").Find(what:=Me.Listbox1.List(i, 0), LookIn:=xlValues, lookat:=xlWhole)
If Not Cel Is Nothing Then
Depart = Cel.Row
Sheets(1).Range("C" & Depart).Value = Sheets(1).Range("C" & Depart).Value + 1
dep = Sheets(1).Range("D" & Depart).Value
End If
fich = Me.Listbox1.List(i, 0) & " (" & dep & ")"
Sheets(3).Range("B1").Value = Me.Listbox1.List(i, 0)
Sheets(3).Range("B2").Value = dep
ActiveWorkbook.SaveCopyAs Filename:=FName & fich
Set VBComp = ThisWorkbook.VBProject.VBComponents("Userform1")
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
ActiveWorkbook.Save
ActiveWorkbook.Close
Set Cel = Nothing
Application.EnableEvents = True
Next i
Listbox1.Clear
End If
Application.ScreenUpdating = True
End Sub |
Partager