XL 2013 Transposer 3 colonnes

[maval]

Bonjour

J'ai sur 3 colonnes des noms que je transpose en formule.

=SI(ESTVIDE(A18);"";"<td width=""33%"" align=""center"" ><a class=""info""  href=""../fiches_deputes/"&B18&".html""> "&A18&" <span><img class=""photo"" src=""../portraits/"&C18&".jpg"" width=""120"" height=""150"" border=""0"" /><P class=""text"">xxxxx<br/>xxxxxxx</P></span></a></td>")

J'aimerai modifier comme ceci soit en formule soit en macro

Et j'aimerai avoir ceci:

<tr>
<td width="33%" align="center" ><a class="info"  href="../fiches_deputes/ian_boucard.html"> M. Ian Boucard <span><img class="photo" src="../portraits/ian boucard.jpg" width="120" height="150" border="0" /><P class="text">xxxxx<br/>xxxxxxx</P></span></a></td>
<td width="33%" align="center" ><a class="info"  href="../fiches_deputes/jean_claude_bouchet.html"> M. Jean-Claude Bouchet <span><img class="photo" src="../portraits/jean-claude bouchet.jpg" width="120" height="150" border="0" /><P class="text">xxxxx<br/>xxxxxxx</P></span></a></td>
<td width="33%" align="center" ><a class="info"  href="../fiches_deputes/florent_boudié.html"> M. Florent Boudié <span><img class="photo" src="../portraits/florent boudié.jpg" width="120" height="150" border="0" /><P class="text">xxxxx<br/>xxxxxxx</P></span></a></td>
</tr>

Je joins mon fichier qui seras plus explicite

Merci d'avance

Max

 

[danielco]

Bonjour,

Essaie :

Sub test()
  Dim Ligne As Long, I As Long, Deb As Long
  Deb = Cells(1, 1).End(xlDown).Row - 1
  For I = Cells(Rows.Count, 1).End(xlUp).Row + 1 To Deb Step -1
    Debug.Print Cells(I, 1).Row
    If (I - 1 - Deb) / 3 = Int((I - 1 - Deb) / 3) Then
      If I = Deb + 1 Then
        Cells(I, 1).EntireRow.Insert
        Cells(I, 6) = "<tr>"
        Exit Sub
      End If
      Cells(I, 1).Resize(2).EntireRow.Insert
      If Cells(I + 2, 6) <> "" Then
        Cells(I + 1, 6) = "<tr>"
      End If
        Cells(I, 6) = "</tr>"
    End If
  Next I
End Sub

Cordialement.

Daniel

 

[maval]

Salut Daniel

C'est super sauf juste un petit problème quand je sélectionne la macro sa fonctionne nickel mais quand je veut revenir au point de départ pour le refaire sur une autre liste je ne peut pas ou alors je doit effacer ligne par ligne .
Est je viens de m'apercevoir qu'il manque les <TR> au début de chaque groupe
Je ne sais pas si je me suis bien exprimer

Merci

Max

 

[danielco]

Est je viens de m'apercevoir qu'il manque les <TR> au début de chaque groupe

Voici ce que j'obtiens :

Qu'est-ce qui ne va pas ?

quand je sélectionne la macro sa fonctionne nickel mais quand je veut revenir au point de départ pour le refaire sur une autre liste je ne peut pas ou alors je doit effacer ligne par ligne .

Est-ce que tu veux que commence par supprimer les balises existantes avant de de les insérer ?

Daniel

 

[maval]

Re,

Oui mais il faudrait pas que les formules de la colonne "G" s'efface?

 

[maval]

Re,

Voila moi se que j'obtiens

A+
Max

 

[danielco]

Bizarre... Essaie :

Sub test()
  Dim Ligne As Long, I As Long, Deb As Long
  Deb = Cells(1, 1).End(xlDown).Row - 1
  For I = Cells(Rows.Count, 1).End(xlUp).Row + 1 To 1 Step -1
    If (Cells(I, 6) = "<tr>" Or Cells(I, 6) = "</tr>") And Cells(I, 6).HasFormula = False Then
      Rows(I).Delete
    End If
  Next I
  For I = Cells(Rows.Count, 1).End(xlUp).Row + 1 To Deb Step -1
    Debug.Print Cells(I, 1).Row
    If (I - 1 - Deb) / 3 = Int((I - 1 - Deb) / 3) Then
      If I = Deb + 1 Then
        Cells(I, 1).EntireRow.Insert
        Cells(I, 6) = "<tr>"
        Exit Sub
      End If
      Cells(I, 1).Resize(2).EntireRow.Insert
      If Cells(I + 2, 6) <> "" Then
        Cells(I + 1, 6) = "<tr>"
      End If
        Cells(I, 6) = "</tr>"
    End If
  Next I
End Sub

Daniel

 

[maval]

Re,

essaye si chez toi sa fonctionne

 

[danielco]

Oui.. sauf que non, parce que les formules sont maintenant en colonne G. Essaie :

Sub test()
  Dim Ligne As Long, I As Long, Deb As Long
  Deb = Cells(1, 1).End(xlDown).Row - 1
  For I = Cells(Rows.Count, 1).End(xlUp).Row + 1 To 1 Step -1
    If (Cells(I, 7) = "<tr>" Or Cells(I, 7) = "</tr>") And Cells(I, 7).HasFormula = False Then
      Rows(I).Delete
    End If
  Next I
  For I = Cells(Rows.Count, 1).End(xlUp).Row + 1 To Deb Step -1
    Debug.Print Cells(I, 1).Row
    If (I - 1 - Deb) / 3 = Int((I - 1 - Deb) / 3) Then
      If I = Deb + 1 Then
        Cells(I, 1).EntireRow.Insert
        Cells(I, 7) = "<tr>"
        Exit Sub
      End If
      Cells(I, 1).Resize(2).EntireRow.Insert
      If Cells(I + 2, 7) <> "" Then
        Cells(I + 1, 7) = "<tr>"
      End If
        Cells(I, 7) = "</tr>"
    End If
  Next I
End Sub

Daniel

 

[maval]

Re,

Oui Nickel juste cet histoire de colonne ........!


Maintenant se qui serais bien ses de remettre comme au départ

Merci beaucoup

Max

 

[danielco]

Maintenant se qui serais bien ses de remettre comme au départ

C'est à dire ?

Daniel

 

[maval]

Quand je doit rentrer une liste de nom dans les trois colonne il faudrait que ma feuille soit vide uniquement les formules dans la colonne "G" de façon que je puisse rentrer les noms et cliquer sur la macro.

Merci

 

[maval]

Re,

En fait si on commence de la ligne "6" ces de supprimer la ligne 6, 10, 11,15, 16, 20, 21 ect… et effacer les colonnes "A, B, C"
un truc comme sa?

 

[danielco]

Bonjour,

Essaie :

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 C.Row = 28 Then Stop
    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

Daniel

 

[maval]

Bonjour Daniel

J'ai une erreur sur la ligne:
If C.Row = 28 Then Stop
aucun message ?
Merci A+

Max