Attribuer un champ à tous les éléments de la ligne (exemple)

Sub Test()
Dim WsS As Worksheet, WsC As Worksheet
Dim DerLig As Long, LigneS As Long, LigneC As Long
Dim DerColS As Integer, ColS As Integer
    Set WsS = Worksheets("Feuil1") 'Feuille source
    Set WsC = Worksheets("Feuil2") 'Feuille cible
    DerLigs = WsS.Range("A" & Rows.Count).End(xlUp)
    LigneC = 1
    For LigneS = 1 To DerLigs
        DerColS = WsS.Cells(LigneS, Columns.Count).End(xlToLeft).Column
        For ColS = 2 To DerColS
            WsC.Cells(LigneC, 1) = WsS.Cells(LigneS, 1)
            WsC.Cells(LigneC, 2) = WsS.Cells(LigneS, ColS)
            LigneC = LigneC + 1
        Next ColS
    Next LigneS
End Sub

Sub test()

Dim DernLigne As Long
DernLigne = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

m = 1
For i = 1 To DernLigne
Sheets(1).Select
x = WorksheetFunction.CountIf(Rows(i & ":" & i), "<>") - 1


Sheets(1).Select
    Range("A" & i).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
Sheets(2).Select
    Range("B" & m).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False

    Range("B" & m).Select
    Selection.Copy
    Range("A" & m + 1 & ":A" & m + x).Select
    ActiveSheet.Paste
    Rows(m & ":" & m).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    m = m + x
    
Next i
End Sub