Soru Şarta Bağlı Rastgele Değer Atama

[emre67z]

Merhaba,

Örnek dosyada da bahsettiğim üzere. İstediğim çalışmayı örnekleme üzerinden anlatacağım.

Güvenlik Departmanında çalışan saha çalışanı 110 personel no'lu Mehmet'e aynı departmanda ve görevde çalışan 3 personel ataması yapılmıştır. atamalar personel no sütununda ye alan personel numarası ile yapılmıştır. Atamalar tamamen rastgele yapılacaktır. Mantık veya Koşul şartı yoktur. Örnek çalışmada buna göre belirlenmiştir.


İlgili süreci formüle dökülmesi yönünde desteklerinizi bekleriz.


Güvenlik-Danışmada da çalışanlar
Bu çalışan grubundan rastgele 3 kişi 170 personel nolu Osman bey'e atanacak. Örnek180,220, 270)
Sonra rastgele 3 kişi 180 no'lu Kahya beye atacak gibi düşünebilirsiniz. Örnek: (250,240,190)
Parantez içerisindeki örnekler gibi.

170	OSMAN
180	KAHYA
190	MERVE
200	GÜLNUR
210	ORHAN
220	FATMA
230	AYŞE
240	HAYRİYE
250	FAZLI
260	KARA
270	GÜLAY

 

[Erkan Akayay]

Office 365 yazdığı için bu formülü yazıyorum. Diğer versiyonlardaçalışmaz.

=METİNBİRLEŞTİR(",";0;İNDİS(BENZERSİZ(SIRALAÖLÇÜT(FİLTRE($A$2:$A$7;$A$2:$A$7<>"");RASGDİZİ(BAĞ_DEĞ_DOLU_SAY($A$2:$A$7);1);1));SIRALI(3)))

 

[MusaPEKEL]

Sub RastgelePersonelAtama()
    Dim ws As Worksheet
    Dim targetPersonnelNo As Long
    Dim rowNum As Long
    Dim i As Integer
    Dim randomPersonnel As String
    
    ' Çalışmak istediğiniz sayfayı belirtin
    Set ws = ThisWorkbook.Sheets("Sayfa1") ' Sayfa adını değiştirin
    
    ' Hedef personelin bilgilerini girin
    targetPersonnelNo = TextBox1.Value ' Örnek olarak 170
    
    ' Hedef personelin bulunduğu satırı bulun
    On Error Resume Next
    rowNum = Application.WorksheetFunction.Match(targetPersonnelNo, ws.Columns("A"), 0)
    On Error GoTo 0
    
    ' Hedef personel bulunamazsa hata mesajı ver
    If rowNum = 0 Then
        MsgBox "Hedef personel bulunamadı!", vbExclamation
        Exit Sub
    End If
    
    ' Hedef personelin bulunduğu satırda başlayarak rastgele 3 kişiyi seçin
    randomPersonnel = ""
    For i = 1 To 3
        If randomPersonnel <> "" Then
            randomPersonnel = randomPersonnel & ", "
        End If
        randomPersonnel = randomPersonnel & RastgelePersonelSec(ws, rowNum)
    Next i
    
    ' Seçilen personelleri hedef personelin yanına yazın
    ws.Cells(rowNum, 5).Value = randomPersonnel
End Sub

Function RastgelePersonelSec(ws As Worksheet, excludeRow As Long) As Long
    Dim lastRow As Long
    Dim randomRow As Long
    
    ' Personel listesinin son satırını bulun
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Rastgele bir satır seçin (hedef satır hariç)
    Do
        randomRow = Application.WorksheetFunction.RandBetween(2, lastRow)
    Loop While randomRow = excludeRow
    
    ' Seçilen satırdaki personel numarasını döndürün
    RastgelePersonelSec = ws.Cells(randomRow, 1).Value
End Function

Private Sub TextBox1_Change()

End Sub

 

[emre67z]

Sub RastgelePersonelAtama()
    Dim ws As Worksheet
    Dim targetPersonnelNo As Long
    Dim rowNum As Long
    Dim i As Integer
    Dim randomPersonnel As String
   
    ' Çalışmak istediğiniz sayfayı belirtin
    Set ws = ThisWorkbook.Sheets("Sayfa1") ' Sayfa adını değiştirin
   
    ' Hedef personelin bilgilerini girin
    targetPersonnelNo = TextBox1.Value ' Örnek olarak 170
   
    ' Hedef personelin bulunduğu satırı bulun
    On Error Resume Next
    rowNum = Application.WorksheetFunction.Match(targetPersonnelNo, ws.Columns("A"), 0)
    On Error GoTo 0
   
    ' Hedef personel bulunamazsa hata mesajı ver
    If rowNum = 0 Then
        MsgBox "Hedef personel bulunamadı!", vbExclamation
        Exit Sub
    End If
   
    ' Hedef personelin bulunduğu satırda başlayarak rastgele 3 kişiyi seçin
    randomPersonnel = ""
    For i = 1 To 3
        If randomPersonnel <> "" Then
            randomPersonnel = randomPersonnel & ", "
        End If
        randomPersonnel = randomPersonnel & RastgelePersonelSec(ws, rowNum)
    Next i
   
    ' Seçilen personelleri hedef personelin yanına yazın
    ws.Cells(rowNum, 5).Value = randomPersonnel
End Sub

Function RastgelePersonelSec(ws As Worksheet, excludeRow As Long) As Long
    Dim lastRow As Long
    Dim randomRow As Long
   
    ' Personel listesinin son satırını bulun
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    ' Rastgele bir satır seçin (hedef satır hariç)
    Do
        randomRow = Application.WorksheetFunction.RandBetween(2, lastRow)
    Loop While randomRow = excludeRow
   
    ' Seçilen satırdaki personel numarasını döndürün
    RastgelePersonelSec = ws.Cells(randomRow, 1).Value
End Function

Private Sub TextBox1_Change()

End Sub

Teşekkürler, Seyahatteydim. object required vba hatası alıyorum. Düzenleyemedim. destek olur musunuz?