Déplacement de données dans Excel à partir d'une colonne en lignes selon les critères de la colonne

Cela utilise des arrays et sera très rapide:

 Sub trnp() Dim rngarr() As Variant Dim oarr() As Variant Dim rng As Range Dim i As Long Dim j As Long Dim r As Long Dim lg As Long j = 1 r = 2 With ThisWorkbook.ActiveSheet Set rng = .Range(.Cells(1, 1), Cells(.Rows.Count, 1).End(xlUp)) lg = .Evaluate("=LARGE(COUNTIF(" & rng.Address & ",""*"" & " & rng.Address & " & ""*""),1)") rngarr = rng.Value ReDim oarr(1 To lg, 1 To 1) oarr(1, 1) = rngarr(1, 1) For i = 2 To UBound(rngarr, 1) If InStr(rngarr(i, 1), Trim(Left(rngarr(i - 1, 1), 6))) > 0 Then oarr(r, j) = rngarr(i, 1) r = r + 1 Else j = j + 1 r = 2 ReDim Preserve oarr(1 To lg, 1 To j) oarr(1, j) = rngarr(i, 1) End If Next i 'paste back array starting in B1 .Range("B1").Resize(UBound(oarr, 1), UBound(oarr, 2)).Value = oarr End With End Sub 

Voici une autre macro VBA qui utilise des arrays et un object défini par l'user pour représenter chaque colonne. L'object défini par l'user se compose d'un élément d'en-tête de colonne et d'une collection d'éléments ci-dessous. Cela devrait être assez rapide. Cela fait des hypothèses sur les locations de données qui devraient être facilement modifiables en haut de la macro.

Module de class

(renommez ceci sur cColHeaders)

 Option Explicit Private pColHeader As Ssortingng Private pColItem As Ssortingng Private pColItems As Collection Private Sub Class_Initialize() Set pColItems = New Collection End Sub Public Property Get ColHeader() As Ssortingng ColHeader = pColHeader End Property Public Property Let ColHeader(Value As Ssortingng) pColHeader = Value End Property Public Property Get ColItem() As Ssortingng ColItem = pColItem End Property Public Property Let ColItem(Value As Ssortingng) pColItem = Value End Property Public Property Get ColItems() As Collection Set ColItems = pColItems End Property Function ADDColItem(Value As Ssortingng) ColItems.Add Value End Function 

Module régulier

 Option Explicit Sub OrganizeByColumn() Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range Dim vSrc As Variant, vRes() As Variant Dim cCH As cColumnHeaders, colCH As Collection Dim I As Long, J As Long Dim lMaxItems As Long 'will be the maximum number of items in a column Dim V As Variant 'set source and results worksheets, ranges Set wsSrc = Worksheets("sheet2") Set wsRes = Worksheets("sheet3") Set rRes = wsRes.Cells(1, 1) 'start results in wsRes A1 'Get source data == assumes in Col A starting at A1 With wsSrc vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With 'Collect and organize the data Set colCH = New Collection For I = 1 To UBound(vSrc, 1) Set cCH = New cColumnHeaders With cCH .ColHeader = vSrc(I, 1) V = Split(.ColHeader) If UBound(V) = 0 Then colCH.Add cCH, .ColHeader Else .ColItem = vSrc(I, 1) .ADDColItem .ColItem colCH(V(0)).ADDColItem (.ColItem) J = colCH(V(0)).ColItems.Count lMaxItems = IIf(lMaxItems > J, lMaxItems, J) End If End With Next I 'Create and populate results array ReDim vRes(0 To lMaxItems, 1 To colCH.Count) For I = 1 To colCH.Count With colCH(I) vRes(0, I) = .ColHeader For J = 1 To .ColItems.Count vRes(J, I) = .ColItems(J) Next J End With Next I 'resize results range Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2)) 'write and format the results With rRes .EntireColumn.Clear .Value = vRes With .Rows(1) .Font.Bold = True .HorizontalAlignment = xlCenter End With .EntireColumn.AutoFit End With End Sub 

En supposant que les caractères maximum dans une valeur avant un espace (s'il y a lieu) sont 6, vous pouvez utiliser une combinaison de RTrim et Left dans une boucle While . Voir ci-dessous:

 Sub test() Range("A1").Select While ActiveCell.Value <> "" If RTrim(Left(ActiveCell.Value, 6)) = RTrim(Left(ActiveCell.Offset(1, 0).Value, 6)) Then ActiveCell.Offset(1, 0).Select Else ActiveCell.Offset(1, 0).Select If ActiveCell.Offset(1, 0).Value = "" Then ActiveCell.Cut ActiveCell.Offset(0, 1).Select Selection.End(xlUp).Select ActiveSheet.Paste Selection.End(xlUp).Select Else Range(Selection, Selection.End(xlDown)).Cut ActiveCell.Offset(0, 1).Select Selection.End(xlUp).Select ActiveSheet.Paste Selection.End(xlUp).Select End If End If Wend End Sub