XL 2019 Réunir du texte

[lynyrd]

Bonjour le forum
y a t'il un moyen (par VBA) d'avoir sur 1 ligne par No de ligne
- le texte en français
- le texte en englais
Merci.

 

[job75]

C'est t'il faisable en VbA

Bien sûr, la macro dans le code de la feuille "Transpose" :

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

Elle se déclenche quand on active la feuille.

 

[lynyrd]

Merci job75
il y a une petite erreur
dans le minitage
c'est le meme au départ qu'a l'arrivée
PS : peut tu rajouter le symbole --> entre les 2 minuteurs
Merci.

 

[lynyrd]

J'ai trouvé pour la 1ere question il faut eemplacer le 2 par le 3
maintenant c'est pout le symbole -->

 

[job75]

J'ai trouvé pour la 1ere question il faut eemplacer le 2 par le 3
maintenant c'est pout le symbole -->

Je ne comprends pas ce que vous voulez.

 

[lynyrd]

par exemple
00:01:02,005 --> 00:01:06,458

 

[job75]

Bonjour lynyrd, le forum,

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

A+

 

[lynyrd]

merci job75
toujours au top
A+

 

[job75]

Ceci est plus simple :

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