Option Explicit
Public Sub Test()
Const CALLER As String = "Test"
Const C_SRC_SHEET_NAME As String = "Tabelle1"
Const C_SRC_ROW_START As Long = 6
Const C_SRC_COLUMN_START = "A"
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
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)
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
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(.Cells(C_DST_ROW_START, C_DST_COLUMN_START), .Cells(.Rows.Count, C_DST_COLUMN_START).End(xlUp))
End With
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
strFormula = "VLOOKUP(RC" & rngDst.Worksheet.Cells(1, C_DST_COLUMN_START).Column & "," & rngSrc.Address(ReferenceStyle:=xlR1C1, External:=True) & ",2,FALSE)"
strFormula = "=IF(ISERROR(" & strFormula & "),""""," & strFormula & ")"
rngDst.FormulaR1C1 = strFormula
Call rngSrc.Cells(2, 2).Copy
Call rngDst.PasteSpecial(xlPasteFormats)
With rngDst.Cells(1)
Call .ClearFormats
.Value = rngSrc.Cells(2).Value
End With
Set rngSrc = rngSrc.Cells(1).Offset(ColumnOffset:=2)
Loop
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