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
|
|