Hej igen.
Ledsen för sent svar, vart på semester. Lade till -1 på två ställen. Bara att ersätta med den tidigare koden.
mvh
Christian


Option Explicit
Sub writeXtimes()

Dim ReadFromSh As Worksheet: Set ReadFromSh = ThisWorkbook.Sheets("Blad1")
Dim lRow As Long: lRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim Rng As Range: Set Rng = ReadFromSh.Range("F1:F" & lRow)
Dim vnt As Variant: vnt = Rng
Dim PrintToSH As Worksheet: Set PrintToSH = ThisWorkbook.Sheets("Blad2")

PrintToSH.UsedRange.ClearContents
Dim i, k: k = 1
For i = 1 To UBound(vnt, 1)
If vnt(i, 1) <> 0 And vnt(i, 1) <> "" Then
PrintToSH.Range("A" & k & ":E" & (vnt(i, 1) + k - 1)).Value = ReadFromSh.Range("A" & i & ":E" & i).Value
k = k + vnt(i, 1)
End If
Next i

Dim newRng As Range: Set newRng = PrintToSH.Range("A1:F" & k - 1)
Call RndRng(newRng, PrintToSH)

End Sub
Function RndRng(Rng As Range, ws As Worksheet)


Dim rngUpper As Long
Dim myRow As Long
rngUpper = Rng.Rows.Count

For myRow = 1 To rngUpper
ws.Cells(myRow, 6).Value = Int((rngUpper * 10 - 1 + 1) * Rnd + 1)
Next myRow

Rng.Sort Key1:=ws.Range("F1"), Order1:=xlAscending, Header:=xlNo
Rng.Columns(6).ClearContents


End Function