Zeilen je nach Wert in Zelle duplizieren

Sub xxxx()
Dim lngCounter As Long, lngRow As Long, lngCol As Long, lngArr As Long
Dim arr(), vntTmp
vntTmp = Cells(1, 1).CurrentRegion
ReDim arr(1 To Application.Sum(Columns(1)) + 1, 1 To UBound(vntTmp, 2))
'Überschrift
lngArr = lngArr + 1
For lngCol = 1 To UBound(vntTmp, 2)
arr(lngArr, lngCol) = vntTmp(1, lngCol)
Next lngCol
'Datensätze
For lngRow = 2 To UBound(vntTmp)
For lngCounter = 1 To vntTmp(lngRow, 1)
lngArr = lngArr + 1
For lngCol = 1 To UBound(vntTmp, 2)
arr(lngArr, lngCol) = vntTmp(lngRow, lngCol)
Next lngCol
Next lngCounter
Next lngRow
With Worksheets.Add
.Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub