Macros d'export de plage en image et en table HTML

Sub ImageCellule()
    ' Objectif    : Enregistrer la plage sélectionnée en images PNG.
    ' Utilisation : Sélectionner une plage unique et lancer la macro.
    ' Retour      : Les images sont enregistrées dans le dossier indiqué dans CstChemin.
    ' Auteur      : Arnaud (www.1forme.fr).
    ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les
    '               même conditions, seulement à titre personnel et citant l'auteur/site d'origine.

    Const CstChemin As String = "C:\MesDoc\_A_Supprimer\" ' A mettre à jour !
    Dim rgPlage     As Range
    Dim strChemin   As String
    
    On Error GoTo erreur
    ' Contrôles
    If Selection Is Nothing Then
        MsgBox "Veuillez sélectionner une plage de cellules.", vbExclamation
        Exit Sub
    End If
    If TypeName(Selection) <> "Range" Then
        MsgBox "Erreur : La sélection n'est pas une plage de cellules.", vbCritical, "Sélection invalide"
        Exit Sub
    End If
    If Selection.Areas.Count > 1 Then
        MsgBox "Erreur : La sélection contient plusieurs plages.", vbCritical, "Sélection invalide"
        Exit Sub
    End If
    If Dir(CstChemin, vbDirectory) = "" Then MkDir CstChemin
    
    Set rgPlage = Selection
    strChemin = CstChemin & IIf(Right(CstChemin, 1) = "\", "", "\") & _
              Replace(rgPlage.AddressLocal(False, False), ":", "-") & "_" & Format(Now(), "yymmdd_hhmmss") & ".png"
    Application.ScreenUpdating = False
    rgPlage.CopyPicture xlScreen, xlPicture
    With Sheets(1).ChartObjects.Add(0, 0, rgPlage.Width, rgPlage.Height)
       .Activate
       DoEvents
       .Chart.Paste
       .Chart.Export strChemin, "png"
       .Delete
    End With
fin:
    Set rgPlage = Nothing
    Application.ScreenUpdating = True
    Exit Sub
erreur:
    MsgBox Err.Description & " (" & Err.Number & ")", vbCritical, "ImageCellule"
    Resume fin
End Sub

Sub CreationTableHTML()
    ' Objectif    : Convertir la sélection en tableau HTML sans mise en forme.
    ' Utilisation : Sélectionner une plage et lancer la macro.
    ' Retour      : Le code Html renvoyé dans la cellule A1 d'une nouvelle feuille et est
    '               copié dans le presse paier Windows.
    ' Auteur      : Arnaud (www.1forme.fr).
    ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les
    '               même conditions, seulement à titre personnel et citant l'auteur/site d'origine.
    
    Dim rgPlage     As Range
    Dim i           As Integer
    Dim j           As Integer
    Dim strHtml     As String
    
    On Error GoTo erreur
    ' Contrôles
    If Selection Is Nothing Then
        MsgBox "Veuillez sélectionner une plage de cellules.", vbExclamation
        Exit Sub
    End If
    If TypeName(Selection) <> "Range" Then
        MsgBox "Erreur : La sélection n'est pas une plage de cellules.", vbCritical, "Sélection invalide"
        Exit Sub
    End If
    If Selection.Areas.Count > 1 Then
        MsgBox "Erreur : La sélection contient plusieurs plages.", vbCritical, "Sélection invalide"
        Exit Sub
    End If

    Set rgPlage = Selection
    
    ' En-tête du Html
    strHtml = "<table border='2'><tbody>"
    
    ' En-tête des colonnes
    strHtml = strHtml & "<tr>"
    For i = 1 To rgPlage.Columns.Count
        strHtml = strHtml & "<th>" & rgPlage.Cells(1, i).Value & "</th>"
    Next i
    strHtml = strHtml & "</tr>"
    
    ' Ajouter de chaque ligne
    For i = 2 To rgPlage.Rows.Count
        strHtml = strHtml & "<tr>"
        For j = 1 To rgPlage.Columns.Count
            strHtml = strHtml & "<td>" & rgPlage.Cells(i, j).Value & "</td>"
        Next j
        strHtml = strHtml & "</tr>"
    Next i
    
    ' Fermeture du code strHtml
    strHtml = strHtml & "</tbody></table>"
    
    ' Renvoie du code Html dans un nouvelle feuille
    With ThisWorkbook.Sheets.Add
        .Name = "TabHtml-" & ActiveSheet.Name
        .Range("A1").Value = strHtml
    End With
    
    ' Copier dans le presse-papiers via HTMLFile
    Set htmlObj = CreateObject("htmlfile")
    htmlObj.ParentWindow.ClipboardData.SetData "text", strHtml
    
fin:
    Set htmlObj = Nothing
    Set rgPlage = Nothing
    Exit Sub
    
erreur:
    MsgBox Err.Description & " (" & Err.Number & ") ", vbCritical, "CreationTableHTML"
    Resume fin
End Sub