Faire des boucles de coller transposer dans une colonne

Bonjour à tous,

Je travaille sur une grosse base de données et je souhaite faire une boucle pour copier transposer des plages de cellules encadrées de cellules vides.

Je joints un un fichier d'exemple avec un onglet de départ et un autre de résultat voulu. Bien sur mon cas est sur une base de 20000 lignes et j'ai mis 3h ce matin pour faire la première.

Je suis novice en programmation du coup je m'adresse à la communauté. Pouvez vous me dire quel code VBA faut-il pour faire ça ?

Merci d'avance

Hello,

Qu'est ce que ça a du être fastidieux ....

Un petit algo simple qui fait le boulot en 4min 40 sur 25 000 lignes ...

Force à toi.

R@g

Salut Junkrat,
Salut Rag,

Premier jet : pas mesuré de temps...
Un double-clic en [A1] démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData
'
If Not Intersect(Target, [A1]) Is Nothing And [A1].Font.Italic = False Then
    Cancel = True
    Application.ScreenUpdating = False
    For x = 2 To Range("C" & Rows.Count).End(xlUp).Row
        If Range("C" & x + 1).Value <> "" Then
            iRow = Range("C" & x).End(xlDown).Row
            tData = Range("C" & x & ":C" & iRow).Value
            Range("C" & x & ":C" & iRow).Value = ""
            Range("C" & x).Resize(1, UBound(tData, 1)).Value = WorksheetFunction.Transpose(tData)
            x = iRow + 1
        Else
            x = x + 1
        End If
    Next
    [A1].Font.Italic = True
    Application.ScreenUpdating = True
End If
'
End Sub

A+

Bonsoir Junkrat, Rag02700, curulis57, le forum,

Une variante.....en transposant sur une autre feuille (test)....

@curulis57 : je suis à la fois fasciné et frustré par ta facilité à rédiger ce code au traitement instantané,

Je m'étais prêté à l'exercice mais je ne suis pas aussi efficace , je poste tout de même,

Sub test()
 Dim deb As Long, fin As Long, i As Integer
 Dim tablo(), tabloR(), tmp(), titres()
 Dim k, derlig, dl

 Application.ScreenUpdating = False

 titres = Array("Références", "Dimensions", "#")

 Sheets("test").Cells.Delete
   For i = 0 To UBound(titres, 1)
    Sheets("test").Cells(1, 1 + i) = titres(i): Sheets("test").Cells(1, 1 + i).Font.Bold = True
  Next i

  derlig = Sheets("test").Range("A" & Rows.Count).End(xlUp).Row + 1
      dl = Sheets("Base de données").Range("A" & Rows.Count).End(xlUp).Row
     deb = 2
     fin = Sheets("Base de données").Range(Cells(2, 2), Cells(dl, 2)).Find("Total*").Row

  While deb <= dl
   tablo = Range(Cells(deb, 1), Cells(fin, 3))
     tmp = Range(Cells(deb, 3), Cells(fin - 1, 3))
   k = 0
   For i = 1 To UBound(tablo, 1)
    ReDim Preserve tabloR(1 To 3, 1 To k + 1)
     tabloR(1, k + 1) = tablo(i, 1)
     tabloR(2, k + 1) = tablo(i, 2)
     k = k + 1
   Next i
      On Error Resume Next
       Sheets("test").Range("A" & derlig).Resize(UBound(tabloR, 2), 2) = Application.Transpose(tabloR)
       Sheets("test").Range("C" & derlig).Resize(1, UBound(tmp, 1)).Value = WorksheetFunction.Transpose(tmp)
        Erase tabloR: Erase tmp
     deb = fin + 1
     fin = Sheets("Base de données").Range(Cells(deb, 2), Cells(dl, 2)).Find("Total*").Row
  derlig = Sheets("test").Range("A" & Rows.Count).End(xlUp).Row + 1
  Wend
 Sheets("test").Activate
End Sub

Cordialement,

Salut la fine équipe,

plus rapide encore, avec un tableau...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, iRow%, iIdx%
'
Cancel = True
Application.ScreenUpdating = False
'
If Not Intersect(Target, [A1]) Is Nothing And [A1].Font.Italic = False Then
    tData = Range("C2").Resize(Range("C" & Rows.Count).End(xlUp).Row, 50).Value
    For x = 1 To UBound(tData, 1)
        If tData(x, 1) = "" Then _
            iRow = 0: _
            iIdx = 0
        If tData(x, 1) <> "" Then _
            iRow = IIf(iRow = 0, x, iRow): _
            iIdx = iIdx + 1: _
            tData(iRow, iIdx) = tData(x, 1): _
            If iIdx > 1 Then tData(x, 1) = ""
    Next
    Range("C2").Resize(UBound(tData, 1), 50).Value = tData
    [A1].Font.Italic = True
End If
'
Application.ScreenUpdating = True
'
End Sub

A+

Ré-écriture plus compacte mais aucun gain de temps.
Faudrait le Dico pour ça...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, iRow%, iIdx%
'
Cancel = True
Application.ScreenUpdating = False
'
If Not Intersect(Target, [A1]) Is Nothing And [A1].Font.Italic = False Then
    tData = Range("C2").Resize(Range("C" & Rows.Count).End(xlUp).Row, 50).Value
    For x = 1 To UBound(tData, 1)
        iRow = IIf(tData(x, 1) = "", 0, IIf(iRow = 0, x, iRow))
        iIdx = IIf(iRow = 0, 0, iIdx + 1)
        If iIdx > 1 Then _
            tData(iRow, iIdx) = tData(x, 1): _
            tData(x, 1) = ""
    Next
    Range("C2").Resize(UBound(tData, 1), 50).Value = tData
    [A1].Font.Italic = True
End If
'
Application.ScreenUpdating = True
'
End Sub

A+

Bonjour à tous, merci de votre aide. Ça a fonctionné comme sur des roulettes !