Combinez les données de plusieurs lignes en une seule ligne

J'ai un tableau contenant des informations sur les personnes (nom, numéro de HP, numéro de domicile, adresse électronique, etc.). Cependant, ils sont dans des lignes différentes et toutes les lignes ne contiennent pas toutes les informations.

Comment combiner toutes les informations sur une personne dans une seule ligne?

Actuel

Voulu

Je ferais cela en utilisant VBA

Sub Pirates()

Range("F:I").Cells.Clear

'first, copy the headers

Range("F1").Value = Range("A1").Value
Range("G1").Value = Range("B1").Value
Range("H1").Value = Range("C1").Value
Range("I1").Value = Range("D1").Value

'now, to work out the content

Dim row As Integer
row = 2

Dim resultRow As Integer
resultRow = 2

Dim previousName As String
    previousName = Range("A" & row).Value


Do While (Range("A" & row).Value <> "")

    Dim currentName As String
    currentName = Range("A" & row).Value

    If (currentName <> previousName) Then
        resultRow = resultRow + 1
        previousName = currentName
    End If

        If Range("A" & row).Value <> "" Then
            Range("F" & resultRow).Value = Range("A" & row).Value
        End If

        If Range("B" & row).Value <> "" Then
            Range("G" & resultRow).Value = Range("B" & row).Value
        End If

        If Range("C" & row).Value <> "" Then
            Range("H" & resultRow).Value = Range("C" & row).Value
        End If

        If Range("D" & row).Value <> "" Then
            Range("I" & resultRow).Value = Range("D" & row).Value
        End If

        row = row + 1



Loop

End Sub

Voici à quoi ressemblait mon Excel

Et après que je lance la macro ci-dessus

Comme vous pouvez le constater, j’ai choisi d’ajouter les résultats à côté du tableau initial, car c’est non destructif.

Cette macro remplira toutes les cellules vides avec les informations correctes si elles sont renseignées sur l'une des lignes. Vous pouvez ensuite utiliser un filtre avancé pour copier des lignes uniques.

Sub CopyData()

Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim k As Long
Dim rownum As Long
Dim colnum As Long

rownum = Application.WorksheetFunction.CountA(Range("A:A"))
colnum = Application.WorksheetFunction.CountA(Range("A1:AAA1"))


For i = 2 To rownum
    For j = 1 To colnum
        If IsEmpty(Cells(i, j)) = False Then
            For k = 1 To rownum
                If Trim(Cells(k, 1)) = Trim(Cells(i, 1)) Then
                    Cells(k, j) = Cells(i, j)
                End If
            Next k


        End If
    Next j
Next i


End Sub