Macro VBA - Fractionner une feuille en plusieurs feuilles

Ça ne va pas arriver souvent, vu que je prône l'utilisation de logiciels libres, mais voici un script VBA pour Excel que j'ai du faire au boulot.

La tâche : j'ai une feuille contenant un tas de rapport de ventes, les uns à la suite des autres, séparés par une ligne vide à chaque fois.
Il fallait splitter chaque rapport dans une nouvelle feuille.

Vu que j'ai du écrire 3 lignes de VBA dans ma vie, il y a plus de 15 ans, j'étais passablement rouillé.
Tellement rouillé qu'en fait j'ai juste été pomper des bouts de codes à droite à gauche pour les mélanger ensemble et espérer que ça marche.
Et ça marche !
Par contre pour le style, on repassera. J'ai tenté de nettoyer le code après coup mais il reste probablement des horreurs qui feront bondir les puristes.

Fichier source

Résultat final

Algorithme en 2 mots
Je duplique la feuille de base, je cherche la 1ère ligne vide, je copie la plage jusqu'à la ligne vide dans une nouvelle feuille au nom du client, je supprime la plage sélectionnée et je recommence.
A la fin je supprime la feuille dupliquée.

Code source

Sub split()
    Dim firstPage As Worksheet
    Set firstPage = Sheets(1) ' La page de référence, à parser et spliter
    
    ' https://msdn.microsoft.com/en-us/library/office/ff837784.aspx
    firstPage.Copy After:=firstPage ' On copie la page de base
    
    Dim copyPage As Worksheet
    Set copyPage = Sheets(2) ' La page copiée, qu'on peut modifier
    copyPage.Name = "temp"
    
    Dim nextBlankRow As Long
    nextBlankRow = firstBlankRow(copyPage)

    While (nextBlankRow > 0)
        Dim clientName As String
        clientName = findClientName(copyPage.Range("A:A"))
        
        Sheets.Add After:=Sheets(Sheets.Count) ' crée une nouvelle feuille et l'ajoute à la fin du classeur
        
        Dim newPage As Worksheet
        Set newPage = Sheets(Sheets.Count) ' On récupère la feuille nouvellement créée
        newPage.Name = clientName ' renome la nouvelle feuille
    
        Dim nbCol As Long
        nbCol = copyPage.UsedRange.Columns.Count
        
        Dim currentRange As Range
        Set currentRange = copyPage.Range("A1", copyPage.Cells(nextBlankRow, nbCol))
        
        ' http://stackoverflow.com/questions/21648122/excel-vba-copy-range-and-paste-values-in-another-sheets-specific-range
        currentRange.Copy ' Copie des valeurs de la 1ère page
        newPage.Range("A1").PasteSpecial xlPasteValues ' on colle dans la nouvelle feuille
        newPage.Columns.AutoFit ' ajuster la taille des colones : http://www.extendoffice.com/documents/excel/1174-excel-split-data-into-multiple-worksheets-based-on-column.html
        newPage.Range("A1").Select ' lâche la sélection
        
        currentRange.Delete ' Supprime la plage pour pouvoir recommencer avec la suivante
        nextBlankRow = firstBlankRow(copyPage)
    Wend
    
    Application.DisplayAlerts = False
    copyPage.Delete
    Application.DisplayAlerts = True
    
    firstPage.Select
    firstPage.Range("A1").Select
End Sub

Function findClientName(fullCol As Range) As String
    For Each cell In fullCol.Cells
        If cell.Value <> "" Then
            findClientName = cell.Value
            Exit For
        End If
    Next
End Function

Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
'http://stackoverflow.com/questions/12497804/finding-first-blank-row-then-writing-to-it

    Dim rngSearch As Range, cel As Range
    With ws
        Set rngSearch = .UsedRange.Columns(1).Find("") '-> does blank exist in the first column of usedRange
        If Not rngSearch Is Nothing Then
            Set rngSearch = .UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks)
            For Each cel In rngSearch
                If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
                    firstBlankRow = cel.Row
                    Exit For
                End If
            Next
        Else '-> no blanks in first column of used range
            If Application.WorksheetFunction.CountA(Cells(.Rows.Count, 1).EntireRow) = 0 Then '-> is the last row of the sheet blank?
                '-> yeap!, then no blank rows!
                firstBlankRow = -1
                'MsgBox "Whoa! All rows in sheet are used. No blank rows exist!"
            Else
                '-> okay, blank row exists
                firstBlankRow = .UsedRange.SpecialCells(xlCellTypeBlanks).Row + 1
            End If
        End If
    End With
End Function

Le fichier qui contient tout
Fichier

Créer une macro VBA
Menu Outils, Macro, Visual Basic Editor

Lancer une macro VBA
Menu Outils, Macro, Macros, sélectionner Feuil1.split (nom de la feuille original + nom de la méthode Sub)

Notez que, par défaut, si vous ouvrez un fichier avec une macro le programme vous avertira des problèmes de sécurité et les désactivera.
Pour les autoriser, rendez-vous dans le menu Outils, Options, onglet Sécurité, bouton Sécurité des macros et sélectionnez Moyen ou Faible.

Sources
Copier une plage de valeurs
Trouver la prochaine ligne vide
Ajuster la taille des colones
Dupliquer une feuille

Versions
Microsoft Excel 2002 (10.2614.2625)
Microsoft Visual Basic 6.3

BlogoGeek