XL 2013 Transposer 3 colonnes

Sub test1()
  Dim Ligne As Long, Ctr As Long, Deb As Long, Tabl(), Plage As Range, C As Range, Ctr1 As Long
  Deb = Cells(1, 1).End(xlDown).Row
  Set Plage = Range("A" & Deb, Cells(Rows.Count, 1).End(xlUp)).Offset(, 6)
  Ctr = -1
  Ctr1 = 0
  Ctr = Ctr + 1
  ReDim Preserve Tabl(Ctr)
  Tabl(Ctr) = "<tr>"
  For Each C In Plage
    If Ctr1 = 2 Then
      Ctr = Ctr + 1
      ReDim Preserve Tabl(Ctr)
      Ctr1 = Ctr1 + 1
      Tabl(Ctr) = C.Value
      Ctr = Ctr + 1
      ReDim Preserve Tabl(Ctr)
      Tabl(Ctr) = "</tr>"
      Ctr = Ctr + 1
      ReDim Preserve Tabl(Ctr)
      Tabl(Ctr) = "<tr>"
      Ctr1 = 0
    Else
      Ctr = Ctr + 1
      Ctr1 = Ctr1 + 1
      ReDim Preserve Tabl(Ctr)
      Tabl(Ctr) = C.Value
    End If
  Next C
  If Ctr1 <> 0 Then
      Ctr = Ctr + 1
      ReDim Preserve Tabl(Ctr)
      Tabl(Ctr) = "</tr>"
  Else
    Tabl(Ctr) = ""
  End If
  Cells.ClearContents
  Cells(Deb, 7).Resize(UBound(Tabl)) = Application.Transpose(Tabl)
End Sub

Sub test()
    Dim hdoc As Object, table As Object, tr As Object, td As Object, img As Object, a As Object, span As Object, p As Object, x As Long, i As Long
    Set hdoc = CreateObject("htmlfile")
    Set table = hdoc.createelement("table"): hdoc.body.appendchild (table)
    Set tr = hdoc.createelement("TR"): table.appendchild (tr)

    For i = 5 To Cells(Rows.Count, "A").End(xlUp).Row
        x = x + 1
        Set td = hdoc.createelement("TD")
        With td.Style: .Width = "33%": .textalign = "center": End With
        Set a = hdoc.createelement("a"): td.appendchild (a)
        a.classname = "info"
        a.href = ".../fiches_deputes/" & Range("B" & i) & ".html"
        a.innerhtml = Range("A" & i)
        Set span = hdoc.createelement("span")
        Set img = hdoc.createelement("img"): span.appendchild (img)
        img.classname = "photo"
        img.src = "src=""../portraits/" & Range("B" & i) & ".jpg"""
        img.Style.Width = "120": img.Style.Height = "150": img.Style.Border = "0"
        Set p = hdoc.createelement("p"): p.classname = "text": p.innerhtml = "xxxxx<br/>xxxxxx"
        span.appendchild (p)
        a.appendchild (span)
        tr.appendchild (td)
        If x = 3 Then x = 0: Set tr = hdoc.createelement("TR"): table.appendchild (tr)
    Next
    Debug.Print hdoc.body.innerhtml
End Sub

Sub test()
    Dim hdoc, table, tr, td, img, a, span, p, x As Long, i As Long
    Set hdoc = CreateObject("htmlfile")
    Set table = hdoc.createelement("table"): hdoc.body.appendchild (table)
    Set tr = hdoc.createelement("TR"): table.appendchild (tr)

    For i = 5 To Cells(Rows.Count, "A").End(xlUp).Row
        x = x + 1
        Set td = hdoc.createelement("TD")
        With td.Style: .Width = "33%": .textalign = "center": End With
        Set a = hdoc.createelement("a"): td.appendchild (a)
        a.classname = "info"
        a.href = ".../fiches_deputes/" & Range("B" & i) & ".html"
        a.innerhtml = Range("A" & i)
        Set span = hdoc.createelement("span")
        Set img = hdoc.createelement("img"): span.appendchild (img)
        img.classname = "photo"
        img.src = "src=""../portraits/" & Range("B" & i) & ".jpg"""
        img.Style.Width = "120": img.Style.Height = "150": img.Style.Border = "0"
        Set p = hdoc.createelement("p"): p.classname = "text": p.innerhtml = "xxxxx<br/>xxxxxx"
        span.appendchild (p)
        a.appendchild (span)
        tr.appendchild (td)
        If x = 3 Then x = 0: Set tr = hdoc.createelement("TR"): table.appendchild (tr)
    Next
    texte = Replace(table.innerhtml, "</TR>", vbCrLf & "</TR>")
    texte = Replace(texte, vbCrLf & "<P class=", "<P class=")
    tablo = Split(texte, vbCrLf)
Cells(5, 7).Resize(UBound(tablo), 1) = Application.Transpose(tablo)
End Sub

Sub Inserer()
Grouper 'RAZ
Dim deb As Range, pas&, ncol%, f$, tablo, ub&, resu(), n&, i&, j&, k%
Set deb = [A5] 'à adapter
pas = 3 'à adapter
ncol = 6 'à adapter
f = deb(1, ncol).FormulaR1C1 'surtout ne pas effacer la formule en F5...
tablo = deb.CurrentRegion.Resize(, ncol)
ub = UBound(tablo)
ReDim resu(1 To ub + 2 * (1 + Int(ub / pas)), 1 To ncol)
n = 1
For i = 1 To ub Step pas
    resu(n, ncol) = "<tr>"
    For j = 1 To pas
        If i + j - 1 > ub Then Exit For
        For k = 1 To ncol - 1
            resu(n + j, k) = tablo(i + j - 1, k)
        Next k
        resu(n + j, k) = f
    Next j
    resu(n + j, ncol) = "</tr>"
    n = n + j + 1
Next i
deb.Resize(n - 1, ncol).FormulaR1C1 = resu 'restitution
End Sub

Sub Grouper()
Application.ScreenUpdating = False
On Error Resume Next 'si aucune SpecialCell
With Columns("F")
    .Replace "<*>", "#N/A", xlWhole
    .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
End With
End Sub

Sub testx()
    Dim hdoc, table, tr, td, img, a, span, p, x As Long, i As Long
    Set hdoc = CreateObject("htmlfile")
    Set table = hdoc.createelement("table"): hdoc.body.appendchild (table)
    Set tr = hdoc.createelement("TR"): table.appendchild (tr)

    For i = 5 To Cells(Rows.Count, "A").End(xlUp).Row
        x = x + 1
        Set td = hdoc.createelement("TD")
        With td: .Width = "33%": .Align = "center": End With
        Set a = hdoc.createelement("a"): td.appendchild (a)
        a.classname = "info"
        a.href = ".../fiches_deputes/" & Range("B" & i) & ".html"
        a.innerhtml = Range("A" & i)
        Set span = hdoc.createelement("span")
        Set img = hdoc.createelement("img"): span.appendchild (img)
        img.classname = "photo"
        img.src = "src=""../portraits/" & Range("B" & i) & ".jpg"""
        img.Style.Width = "120": img.Style.Height = "150": img.Style.Border = "0"
        Set p = hdoc.createelement("p"): p.classname = "text": p.innerhtml = "xxxxx<br/>xxxxxx"
        span.appendchild (p)
        a.appendchild (span)
        tr.appendchild (td)
        If x = 3 Then x = 0: Set tr = hdoc.createelement("TR"): table.appendchild (tr)
    Next
    texte = Replace(table.innerhtml, "</TR>", "</TR>" & vbCrLf)
texte = Replace(texte, vbCrLf & "<P class", "<P class")
tablo = Split(texte, vbCrLf)
Cells(5, "F").Resize(UBound(tablo), 1) = Application.Transpose(tablo)
End Sub