Mise en forme d'un fichier

[PBO229]

Bonjour à tous,

Je dois faire une macro pour mettre en forme un fichier.
Je dois:
-supprimer les 20 premières lignes (ok)
-supprimer les lignes après le total général
-défusionner les cellules (ok)
-Recopier le nom du vendeur sur chaque ligne jusqu'à ce que le nom d'un autre vendeur apparaisse (ok)
-Dans la colonne total général, je dois copier le pourcentage et le coller dans la colonne suivante sur la même ligne que le total.
-Supprimer toutes les lignes qui correspondent aux pourcentages

Voilà mon code qui fonctionne mais qui est très lent.

Sub Mise_en_forme_FID()
'
' Mise_en_forme_FID Macro

Application.ScreenUpdating = False
Dim i As Integer
Dim j As Integer
Dim ligneactive As Long
Dim derlig As Long
Dim comm As String
derlig = Range("A65536").End(xlUp).Row
For i = 20 To 1 Step -1
Rows(i).EntireRow.Delete
Next i

    Cells.Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    
    End With
 
 Range("A4").Select
 
 While ActiveCell.Value = ""
 ligneactive = ActiveCell.Row
 Cells(ligneactive, 1).Value = Cells(3, 1).Value
 ActiveCell.Offset(1, 0).Activate
 Wend
 
  ligneactive = ActiveCell.Row
 
 For j = ligneactive To derlig
 
 If Cells(j, 1).Value <> Cells(j - 1, 1) Then
 
 Cells(j + 1, 1).Select
 While ActiveCell.Value = ""
 comm = ActiveCell.Row
 Cells(comm, 1).Value = Cells(j, 1).Value
 ActiveCell.Offset(1, 0).Activate
 Wend
 End If
 
 Next j
 
 
End Sub

Je vous joins un exemple de fichier. Le nombre de lignes entre les commerciaux n'est pas constant.
Avez-vous des idées pour l'améliorer et faire les deux derniers points?

Merci à vous

 

[Paf]

Re : Mise en forme d'un fichier

Bonjour,

bien que tardif, une macro qui réalise, a priori, le besoin

Sub Mise_en_forme_FID()
'
' Mise_en_forme_FID Macro

 Application.ScreenUpdating = False
 Dim i As Integer
 Dim derlig As Long
 
 With Worksheets("Feuil1")
 
 '*** suppression des 20 premières lignes
 .Rows("1:20").Delete

  '*** determination dernière ligne utile
 derlig = .Range("C65536").End(xlUp).Row
 
 '*** suppression des lignes après le tableau
    .Rows(derlig + 1 & ":" & derlig + 4).Delete
 
 '*** suppression des fusionnements
   With .Range("A1:G" & derlig)
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .MergeCells = False
    End With
    
 '*** remplissage nom
 For i = 3 To derlig
    If .Cells(i, 1) = "" And .Cells(i, 2) <> "Sous-total" Then .Cells(i, 1) = .Cells(i - 1, 1)
 Next
 
 'déplacement % et suppression lignes %
 For i = derlig To 3 Step -1
    If .Range("G" & i).NumberFormat = "0%" Then
        .Range("G" & i).Offset(-1, 1) = Range("G" & i)
        .Range("G" & i).Offset(-1, 1).NumberFormat = "0%"
        .Rows(i).Delete
    End If
 Next
 End With
  Application.ScreenUpdating = True
End Sub

A+