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
|
Sub CreerNouvelleFeuille()
Dim fs As Worksheet 'Feuille source
Dim fd As Worksheet 'Feuille destination
Dim ilS As Integer 'Ligne dans fichier source
Dim ilD As Integer 'Ligne dans fichier destination
Dim iMemo As String 'Memo num dossier
Dim Mem As String
Dim derligne As Integer
Set fs = ThisWorkbook.Sheets(1)
'Création feuille destination
Set fd = ThisWorkbook.Worksheets.Add
fs.Activate
Rows(1).Copy Destination:=Worksheets(1).Cells(1, 1)
derligne = fs.Cells(65535, 1).End(xlUp).Row
ilD = 2
For ilS = 2 To derligne
iMemo = fs.Cells(ilS, 1)
Cells(ilS, 1).Copy Destination:=Worksheets(1).Cells(ilD, 1)
If iMemo <> fs.Cells(ilS + 1, 1) Then 'Changement de ligne
fs.Cells(ilS, 1).Copy Destination:=fd.Cells(ilD, 1)
ilD = ilD + 1
Else 'Case des autres lignes
fd.Cells(ilD, 2) = fd.Cells(ilD, 2) & " " & fs.Cells(ilS, 2)
End If
Next
End Sub |
Partager