Aktif Satırda Rastgele Hücre Seçmek

[meslek5]

Merhaba sayın hocalarım, aktif satırda 21. ve 90. sütunlar arasında rastgele dolu hücre seçmek için nasıl bir kod kullanmamız gerekiyor. Saygılar

 

[Emir Hüseyin Çoban]

.

Sub kod()


    sat = Selection.Row

tekrar:
    ra = WorksheetFunction.RandBetween(21, 90)
    If Cells(sat, ra) <> "" Then
        If Not d Like "*" & ra & "*" Then
            Cells(sat, ra).Select
            Exit Sub
        Else
            d = d & "#" & ra
        End If
    End If
    GoTo tekrar

End Sub

.

 

[meslek5]

.

Sub kod()


    sat = Selection.Row

tekrar:
    ra = WorksheetFunction.RandBetween(21, 90)
    If Cells(sat, ra) <> "" Then
        If Not d Like "*" & ra & "*" Then
            Cells(sat, ra).Select
            Exit Sub
        Else
            d = d & "#" & ra
        End If
    End If
    GoTo tekrar

End Sub

.

Hocam bu kodu denedim fakat dolu hücrelerde rastgele seçim yapmıyor. Aşağıdaki kodu Yusuf bey paylaşmıştı ve kodun amacı belirtilen aralıktaki satırda boş hücre olan ve değeri "+" olmayan hücreleri rastgele seçmek. Aynı bu kodu yine değeri "+" olmayan, dolgu renksiz olan ve bu defa dolu olan hücrelerde ve en önemlisi aktif satırda çalıştırabilir miyiz?

Örneğin herhangi bir satırdayım ve bu satırda 21. ve 90. sütunlar arasındaki hücrelerde sadece dolu olan ve değeri "+" olmayan, dolgu renksiz olan rastgele bir hücre seçsin.

Sub bos_hucre_sec ()
Dim RNG As Range
Set RNG = Range("U22:CL22")
Dim randomCell As Long
If WorksheetFunction.CountBlank(RNG) > 0 Then
Do
randomCell = Int(Rnd * RNG.Cells.Count) + 1
Loop Until RNG.Cells(randomCell) = Empty
RNG.Cells(randomCell).Select
End If
End Sub

 

[meslek5]

.

Sub kod()


    sat = Selection.Row

tekrar:
    ra = WorksheetFunction.RandBetween(21, 90)
    If Cells(sat, ra) <> "" Then
        If Not d Like "*" & ra & "*" Then
            Cells(sat, ra).Select
            Exit Sub
        Else
            d = d & "#" & ra
        End If
    End If
    GoTo tekrar

End Sub

.

Hocam son mesajıma (3 nolu) bakabildiniz mi?

 

[meslek5]

Ya da Korhan hocam müsaitseniz sizde bir göz atabilir misiniz?

 

[halit3]

Alternatif olarak bu kodu bir dene

Sub deneme10()

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

sat = ActiveWindow.RangeSelection.Row

say2 = 0
For i = 21 To 90
atla1:
say = Int((Rnd * 90) + 1)
say2 = say2 + 1
If say2 = 2000 Then MsgBox "hiç veri yok": GoTo atla2
If Cells(sat, say) = "" Then GoTo atla1
If say < 20 Then GoTo atla1
If Cells(sat, say) = "+" Then GoTo atla1
MsgBox Cells(sat, say)
MsgBox say

Exit For
Next i
atla2:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

MsgBox "işlem tamam"
End Sub

 

[veyselemre]

Sub aktifSatirAraliktanDolgusuzNegatifSec()
    Dim col As New Collection
    On Error GoTo uygunYok
    Set Rng = Intersect(Rows(ActiveCell.Row).SpecialCells(xlCellTypeConstants, 1), Range("u:cl"))
    For Each cell In Rng
        If cell.Value < 0 And cell.Interior.ColorIndex = xlNone Then col.Add cell
    Next
    If col.Count > 0 Then
        col(WorksheetFunction.RandBetween(1, col.Count)).Select
    Else
        GoTo uygunYok
    End If
    Exit Sub
uygunYok:
    On Error Resume Next
    MsgBox "Uygun Hücre Yok"
End Sub

 

[Haluk]

Alternatif olarak bu kodu bir dene
......
....

@erdem_emre 'ye söyle de, bu mesajına da "Beğeni" vermeyi unutmasın.....

.

 

[meslek5]

Yardımcı olan herkese teşekkür ederim. Ancak yukarıdaki kodların hepsi hata verdi.
Ne yapmak istediğimi tam anlatamadım galiba. Demek istediğim şu: o an bulunduğum satır üzerinde U:CL sütunları arasında rastgele bir hücre seçsin ama seçerken şuna dikkat etsin hücre değeri "+" olmayacak ve dolgu rengi kırmızı olmayacak. Yani mesaj kutusunda hücre değerini vermesine gerek yok.

Aşağıdaki kod hücre değeri "+" olmayanı rastgele seçiyor ve çok hızlı çalışıyor.
Bu koda sadece şu iki kriter eklenecek
1-Dolgu rengi kırmızı olmasın
2-bulunduğun satırın U:CL sütunlarında seçim yapacak sadece


Sub rastgele_sec()
On Error Resume Next
Range("t16").Value = Range("t16").Value + 1
Dim RNG As Range
Set RNG = Range("U22:CL22")
Dim randomCell As Long
If WorksheetFunction.CountBlank(RNG) = 0 Then
Do
randomCell = Int(Rnd * RNG.Cells.Count) + 1
Loop Until RNG.Cells(randomCell) <> "+"
RNG.Cells(randomCell).Select
End If
End Sub