Bin mir nicht 100% sicher ob ich dich richtig verstanden habe, aber versuch es mal damit:

(bei Fragen, beachte bitte zuerst die Kommentare)

Option Explicit

Public Sub Test()
  
  Const CALLER As String = "Test"
  
'>> Hier können Anpassungen vorgenommen werden
'>>>>
  'Angaben zur Quelle
  Const C_SRC_SHEET_NAME As String = "Tabelle1"
  Const C_SRC_ROW_START As Long = 6
  Const C_SRC_COLUMN_START = "A"
  'Angaben zum Ziel
  Const C_DST_ROW_START As Long = 1
  Const C_DST_COLUMN_START = "A"
'<<<<
'<<
  
  On Error GoTo ErrHandler
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  Dim wksSrc As Excel.Worksheet
  Dim rngSrc As Excel.Range
  Dim rngDst As Excel.Range
  Dim strFormula As String
  
  'Zielort festlegen/erstellen/vorbereiten
  Set wksSrc = Worksheets(C_SRC_SHEET_NAME)
  With Worksheets.Add(After:=wksSrc)
    .Name = Format$(Now, "yyyy-mm-dd_hhmmss")
    Set rngDst = .Cells(C_DST_ROW_START, C_DST_COLUMN_START)
  End With
  rngDst.Value = "Datum WP"
  Set rngDst = rngDst.Offset(1)
  
  'alle Daten an Zielort kopieren ...
  With wksSrc
    Set rngSrc = .Cells(C_SRC_ROW_START, C_SRC_COLUMN_START)
    Do While rngSrc.Cells(1).Text <> ""
      Set rngSrc = .Range(rngSrc, .Cells(.Rows.Count, rngSrc.Column).End(xlUp))
      With rngSrc.Resize(rngSrc.Rows.Count - 1).Offset(1)
        Call .Copy(rngDst)
        Set rngDst = rngDst.Offset(.Rows.Count)
      End With
      Set rngSrc = rngSrc.Cells(1).Offset(ColumnOffset:=2)
    Loop
  End With
  '... und doppelte Daten entfernen
  With rngDst.Worksheet
    With .Range(.Cells(C_DST_ROW_START, C_DST_COLUMN_START), rngDst.Offset(-1))
      Call .Sort(.Cells(1), xlAscending, Header:=xlYes)
      Call .RemoveDuplicates(Columns:=1, Header:=xlYes)
    End With
    Set rngDst = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
  End With
  
  'je WP die Informationen zu den Daten ermitteln und anzeigen
  Set rngSrc = rngSrc.Worksheet.Cells(C_SRC_ROW_START, C_SRC_COLUMN_START)
  Do While rngSrc.Text <> ""
    
    Set rngDst = rngDst.Offset(ColumnOffset:=1)
    
    With rngSrc.Worksheet
      Set rngSrc = .Range(rngSrc, .Cells(.Rows.Count, rngSrc.Column).End(xlUp))
      Set rngSrc = rngSrc.Resize(ColumnSize:=2)
    End With
    
    'Informationen werden durch Formel (SVERWEIS) in Z1S1-Schreibweise ermittelt
    strFormula = "VLOOKUP(RC1," & rngSrc.Address(ReferenceStyle:=xlR1C1, External:=True) & ",2,FALSE)"
    strFormula = "=IF(ISERROR(" & strFormula & "),""""," & strFormula & ")"
    
    rngDst.FormulaR1C1 = strFormula
'    rngDst.Value = rngDst.Value 'Formeln in Werte umwandeln
    
    'Format der ersten Werte-Zelle für alle Zellen übernehmen...
    Call rngSrc.Cells(2, 2).Copy
    Call rngDst.PasteSpecial(xlPasteFormats)
    With rngDst.Cells(1)
      Call .ClearFormats '...außer für die Spaltenbeschriftung
      .Value = rngSrc.Cells(1).Value 'Spaltenbeschriftung für WP setzen
    End With
    
    'nächstes WP
    Set rngSrc = rngSrc.Cells(1).Offset(ColumnOffset:=2)
  Loop
  
  ' abschließend noch etwas "Kosmetik" ;)
  rngDst.Worksheet.Cells(C_DST_ROW_START, C_DST_COLUMN_START).Select
  
  
SafeExit:
  Application.CutCopyMode = False
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Sub

ErrHandler:
  Call MsgBox("Fehler: " & Err.Number & vbNewLine & vbNewLine & _
              "Beschreibung:" & vbNewLine & _
              Err.Description, _
            Title:="Fehler in '" & CALLER & "'", _
            Buttons:=vbCritical)
  GoTo SafeExit
End Sub