XL 2019 Réunir du texte

Private Sub Worksheet_Activate()
Dim tablo, resu, i&, n&
tablo = Sheets("Import").ListObjects(1).Range.Resize(, 4)
ReDim resu(1 To 1 + 4 * (UBound(tablo) - 1), 1 To 2)
For i = 2 To UBound(tablo)
    If Trim(CStr(tablo(i, 1))) <> "" Then
        n = n + 1
        resu(n, 1) = tablo(i, 1): n = n + 1
        resu(n, 1) = tablo(i, 2)
        resu(n, 2) = tablo(i, 2): n = n + 1
        resu(n, 1) = tablo(i, 4)
        n = n + 1
    End If
Next i
'---restitution---
Application.ScreenUpdating = False
Cells.Clear 'RAZ
On Error Resume Next 'si aucune SpecialCell
With [A2]
    If n Then .Resize(n, 2) = resu
    With Range(.Offset(-1), Me.UsedRange)
        .HorizontalAlignment = xlLeft
        .AutoFilter 1, "<1" 'filtre automatique
        With .SpecialCells(xlCellTypeVisible)
            .HorizontalAlignment = xlCenter
            .NumberFormat = "hh:mm:ss.000"
        End With
        .AutoFilter 'ôte le filtre
        .Columns(2).HorizontalAlignment = xlCenter
        .Columns(2).NumberFormat = "hh:mm:ss.000"
        .Rows(1).Delete xlUp
        .Columns.ColumnWidth = 12
    End With
End With
End Sub

Private Sub Worksheet_Activate()
Dim tablo, resu, i&, n&
tablo = Sheets("Import").ListObjects(1).Range.Resize(, 4)
ReDim resu(1 To 1 + 4 * (UBound(tablo) - 1), 1 To 3)
For i = 2 To UBound(tablo)
    If Trim(CStr(tablo(i, 1))) <> "" Then
        n = n + 2
        resu(n, 1) = tablo(i, 1): n = n + 1
        resu(n, 1) = tablo(i, 2)
        resu(n, 2) = "-->"
        resu(n, 3) = tablo(i, 3): n = n + 1
        resu(n, 1) = tablo(i, 4)
    End If
Next i
'---restitution---
Application.ScreenUpdating = False
Cells.Clear 'RAZ
On Error Resume Next 'si aucune SpecialCell
With [A1]
    If n Then .Resize(n, 3) = resu
    With Range(.Cells, Me.UsedRange)
        .HorizontalAlignment = xlLeft
        .AutoFilter 1, "<1" 'filtre automatique
        With .SpecialCells(xlCellTypeVisible)
            .HorizontalAlignment = xlCenter
            .NumberFormat = "hh:mm:ss.000"
        End With
        .AutoFilter 'ôte le filtre
        .Rows(1).Delete xlUp
        .Columns.ColumnWidth = 12
        .Columns(2).AutoFit
    End With
End With
End Sub

Private Sub Worksheet_Activate()
Dim tablo, resu, i&, n&
tablo = Sheets("Import").ListObjects(1).Range.Resize(, 4)
ReDim resu(1 To 1 + 4 * (UBound(tablo) - 1), 1 To 3)
For i = 2 To UBound(tablo)
    If Trim(CStr(tablo(i, 1))) <> "" Then
        n = n + 2
        resu(n, 1) = tablo(i, 1): n = n + 1
        resu(n, 1) = tablo(i, 2)
        resu(n, 2) = "-->"
        resu(n, 3) = tablo(i, 3): n = n + 1
        resu(n, 1) = tablo(i, 4)
    End If
Next i
'---restitution---
Application.ScreenUpdating = False
Cells.Clear 'RAZ
If n = 0 Then Exit Sub
With [A1]
    .Resize(n, 3) = resu
    With Range(.Cells, Me.UsedRange)
        .HorizontalAlignment = xlLeft
        .AutoFilter 1, "<1" 'filtre automatique
        With .SpecialCells(xlCellTypeVisible)
            .NumberFormat = "hh:mm:ss.000"
            .Columns.AutoFit 'ajustement largeurs
        End With
        .AutoFilter 'ôte le filtre
        .Rows(1).Delete xlUp
    End With
End With
End Sub