Hallo,

der folgende VBA-Code setzt voraus, dass in Tabelle1 die Kundenstammdaten befinden und sich in Tabelle2 die Ausgangstabelle vorhanden ist.

In beiden Tabellen muss jeweils immer in Zeile1 die Überschrift vorhanden sein.

Sub Daten_Analyse()
    Dim rngRow As Range
    Dim rngDestRow As Range
    
    Dim lRowDest As Long
    
    Dim shSrc As Worksheet
    Dim shDest As Worksheet
    Dim sVName As String, sName As String, sAdr As String
    Dim sEmail1 As String, sEmail2 As String, sEmail3 As String
    Dim sTel1 As String, sTel2 As String, sTel3 As String
    
    Set shSrc = Tabelle1
    Set shDest = Tabelle2
    
    For Each rngRow In shSrc.UsedRange.Rows
        If rngRow.Row > 1 Then      ' Überschriften ignorieren
            sVName = rngRow.Cells(1, 1)
            sName = rngRow.Cells(1, 2)
            sAdr = rngRow.Cells(1, 3)
            sEmail1 = rngRow.Cells(1, 4)
            sEmail2 = rngRow.Cells(1, 5)
            sEmail3 = rngRow.Cells(1, 6)
            sTel1 = rngRow.Cells(1, 7)
            sTel2 = rngRow.Cells(1, 8)
            sTel3 = rngRow.Cells(1, 9)
            
            ' Neue Zeile in Zieltabelle finden
            lRowDest = FindNextEmptyRow(shDest)
            Dim iRowDestOff As Integer
            Dim sTel As String, sEmail As String, sTelTMP As String
            Dim iNum As Integer
            
            With shDest.Rows(lRowDest)
                iRowDestOff = 0
                For iNum = 1 To 3
                    sTel = IIf(iNum = 1, sTel1, IIf(iNum = 2, sTel2, sTel3))
                    sEmail = IIf(iNum = 1, sEmail1, IIf(iNum = 2, sEmail2, sEmail3))
                    If Not (sTel = "" And sEmail = "") Then
                        iRowDestOff = iRowDestOff + 1
                        
                        .Cells(iRowDestOff, 1).Value = sVName
                        .Cells(iRowDestOff, 2).Value = sName
                        .Cells(iRowDestOff, 3).Value = sAdr
                        
                        .Cells(iRowDestOff, 4).Value = sEmail
                        .Cells(iRowDestOff, 7).Value = IIf(sTel = "", sTelTMP, sTel)
                        sTelTMP = sTel
                    End If
                Next
            End With
        End If
    Next
End Sub

' Findet nächsten leere Zeile in Tabelle
Function FindNextEmptyRow(sh As Worksheet) As Long
    Dim lRow As Long
    Dim iCol As Integer
    Dim bOK As Boolean
    lRow = 1
    Do
        lRow = lRow + 1
        For iCol = 1 To 9
            bOK = (sh.Cells(lRow, iCol).Value = "")
            If Not bOK Then Exit For
        Next
    Loop While bOK = False
    FindNextEmptyRow = lRow
End Function

Ergebnis: