Altın gün çekilişi

[muratgunay48]

Arkadaşlar, hocalarım. Ben internetten bir çekiliş dosyası buldum. Aynen yazdım (kopyalamak yoktu). Oradaki videoda çalışıyor, ben de 1 yerde hata veriyor. Ne hatası bu acaba. Yardımcı olursanız sevinirim.
Saygılarımla.

 

[askm]

Kodu aşağıdaki şekilde değiştirin.

Sub cekilis()

Dim Counter As Integer
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row
On Error GoTo myErrorCheck
Application.EnableCancelKey = xlErrorHandler

ActiveWorkbook.Names.Add "Liste", RefersToR1C1:="=kura!R1C1:R" & son & "C1"
Range("Liste").Offset(0, 1).Select
Selection.ClearContents

Counter = 1
While Counter < Range("Liste").Rows.Count
    For Each www In Worksheets(1).Range("Liste")
        Randomize
        
        Selection.Interior.ColorIndex = xlNone
        Range(www.Address()).Select
        Selection.Interior.ColorIndex = 24
        
        If Int((10 * Range("Liste").Rows.Count + 1) * Rnd()) = Selection.Row Then
            If Selection.Offset(0, 1).Value = "" Then
                Selection.Offset(0, 1).Value = Counter
                Counter = Counter + 1
            End If
        End If
            
    Next
Wend

For Each www In Worksheets(1).Range("Liste")
    If www.Offset(0, 1).Value = "" Then
        www.Offset(0, 1).Value = Counter
    End If
Next

myErrorCheck:
    If Err = 18 Then
        If MsgBox("Bozuldu", 4, "muratgunay48") = 7 Then
            Resume Next
        End If
    End If
    
Selection.Interior.ColorIndex = xlNone

Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
               OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
                
End Sub

 

[muratgunay48]

Kodu aşağıdaki şekilde değiştirin.

Sub cekilis()

Dim Counter As Integer
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row
On Error GoTo myErrorCheck
Application.EnableCancelKey = xlErrorHandler

ActiveWorkbook.Names.Add "Liste", RefersToR1C1:="=kura!R1C1:R" & son & "C1"
Range("Liste").Offset(0, 1).Select
Selection.ClearContents

Counter = 1
While Counter < Range("Liste").Rows.Count
    For Each www In Worksheets(1).Range("Liste")
        Randomize
       
        Selection.Interior.ColorIndex = xlNone
        Range(www.Address()).Select
        Selection.Interior.ColorIndex = 24
       
        If Int((10 * Range("Liste").Rows.Count + 1) * Rnd()) = Selection.Row Then
            If Selection.Offset(0, 1).Value = "" Then
                Selection.Offset(0, 1).Value = Counter
                Counter = Counter + 1
            End If
        End If
           
    Next
Wend

For Each www In Worksheets(1).Range("Liste")
    If www.Offset(0, 1).Value = "" Then
        www.Offset(0, 1).Value = Counter
    End If
Next

myErrorCheck:
    If Err = 18 Then
        If MsgBox("Bozuldu", 4, "muratgunay48") = 7 Then
            Resume Next
        End If
    End If
   
Selection.Interior.ColorIndex = xlNone

Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
               OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
               
End Sub

Hocam çok teşekkür ederim. Başlıklar gitmiş ama çok da sorun değil. Elinize emeğinize sağlık.
Saygılarımla.