[bbil]

tiens j'ai quelque chose mais c'est un peu long ...

tous d'abords une fonction pour mémoriser l'emplacement des "bords" des colonnes... :

'
' Calcule emplacement des colonnes..
'
'
Private Sub Mes_Tableaux(T, tMes() As Single)
    Dim r As Row
    Dim c As Cell
    Dim sLargeur As Single
    Dim bTrouve As Boolean
    Dim i As Integer
    Dim j As Integer
    ReDim Preserve tMes(0)
    tMes(0) = 0
    For Each r In T.Range.Rows
        sLargeur = 0
        
        For Each c In r.Range.Cells
         sLargeur = sLargeur + c.PreferredWidth
         i = 0
         bTrouve = False
         While i <= UBound(tMes) And Not bTrouve
            If tMes(i) < sLargeur Then
             i = i + 1
             Else
              bTrouve = True
            End If
           Wend
           If Not bTrouve Then
              If tMes(i - 1) < sLargeur - 0.01 Then
                ReDim Preserve tMes(i)
                tMes(i) = sLargeur
              End If
           Else
            If tMes(i) - sLargeur > 0.1 Then
               For j = UBound(tMes) To i + 1 Step -1
                 tMes(j) = tMes(j - 1)
                Next
                 tMes(i) = sLargeur
            End If
           End If
        Next
    Next
 
End Sub

Puis une fonction qui à partir de la mémorisation précédente des "bords" des colonnes , et des "bords" d'une cellule , renvoi le nombre de cellules fusionnées...

'
' Calcul NbColonnes
'
'
Private Function iNbCol(c As Cell, sDepart As Single, tMes() As Single) As Integer
 Dim iDeb As Integer
 Dim iFin As Integer
 Dim i As Integer
 Dim bTrouver As Boolean
 iDeb = 0
 iFin = 0
 bTrouve = False
 While i <= UBound(tMes) And Not bTrouve
   If tMes(i) < sDepart + 0.01 Then iDeb = i
   iFin = i
   If tMes(i) >= c.PreferredWidth + sDepart Then bTrouve = True
      
   i = i + 1
  Wend
 iNbCol = iFin - iDeb
End Function
 

et maintenant l'utilisation dans ta fonction .. :

Private Sub Conv_Tableaux_Click()
    Dim T As Table ' T c'est mon tableau
    Dim r As Row
    Dim stTexte As String
    Dim sDepart As Single
    Dim stColSpan As String 'colonne fusionee
    Dim iCol As Integer
    Dim c As Cell
     Dim tMes() As Single 'Tableau emplacement des colonnes...
    Set T = ActiveDocument.Tables(1) ' Je prend le 1° tableau du document
    Mes_Tableaux T, tMes
    stTexte = "<center><table width=100% border=1>"
    For Each r In T.Range.Rows
       sDepart = 0
       stTexte = stTexte & "<TR>"
       For Each c In r.Range.Cells
         stColSpan = ""
         iCol = iNbCol(c, sDepart, tMes)
         If iCol > 1 Then stColSpan = " colspan=" & iCol & " "
         
         stTexte = stTexte & "<TD" & stColSpan & "><div align=center>" & NetCellule(c.Range.Text) & "</div></TD>"
         sDepart = sDepart + c.PreferredWidth
       Next
       stTexte = stTexte & "</TR>" & Chr(13)
    Next
     stTexte = stTexte & "</TABLE></center>"
     
          stTexte = stTexte & "</TABLE>"
     Debug.Print stTexte
     T.Select
     T.Delete
     Selection.TypeText Text:=stTexte
End Sub
 

bon courage....