Delila10 Creative Commons License 2010.11.17 0 0 13298

Rájöttem a hibára, most már nem ad egyforma sorokat.

 

Sub veletlen_2()
    Dim db As Integer, sor As Integer, sor_1 As Integer
    Dim usor As Integer, f As Boolean, uoszlop As String
        
    Sheets(1).Select
    usor = ActiveSheet.UsedRange.Rows.Count
    db = InputBox("Hány sort akarsz másolni?")
    sor_1 = 2
    For i = 1 To db
        sor = Int(Rnd() * usor) + 2 'Címsort feltételezve
        Rows(sor).EntireRow.Copy Sheets(2).Rows(sor_1)
        sor_1 = sor_1 + 1
    Next
    
    Sheets(2).Select
    db = db + 1
    uoszlop = Chr(ActiveSheet.UsedRange.Columns.Count + 64)
    Do
        Range("A2:" & uoszlop & db).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
            xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        f = False
        For i = 3 To db
            If Cells(i, 1) = Cells(i - 1, 1) Then
                sor = Int(Rnd() * usor) + 2
                Sheets(1).Rows(sor).EntireRow.Copy Rows(i)
                f = True
            End If
        Next
    Loop While f <> False
   
    Range("A2:" & uoszlop & db).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
    'Ellenőrzés
    uoszlop = Chr(ActiveSheet.UsedRange.Columns.Count + 65)
    Range(uoszlop & "2:" & uoszlop & db + 1) = "=if(A2=A3, ""Egyforma"","""")"
 
End Sub

Előzmény: Delila10 (13297)