rastgele veriyi istenen alanda yazdırma

ghostnova · 7 Mart 2025

Merhaba, d3ten başlayıp d sütunundaki son hücreye kadar olan verileri rastgele seçip başka bir sütuna (örneğin p sütunu) yazdırmak istiyorum. Ama bazı kurallarla rastgele seçilen değer bir daha seçilmiycek ve eğer seçilen değerin bulunduğu satırın yanındaki sütunda yani e sütunundaki satır değerine bakcak sonra yazılmak istenen sütunda bulunduğu satırın bu sefer hem g hem de f deki değerine baksın eğer e deki satır değeri hem g hemde f deki satır değerine eşit değilse o zaman hücreye(pdeki) yazsın sonra aynı kural bir alt satırda da sağlanıyorsa yani seçilen hücrenin e deki satır değeri yazılıcak hücrenin bir alt satırının g ve f değeri hala daha eşit değilse o zaman bir alt hücreyede rastegele seçilen(ilk başta seçtiği) değer yazılsın. e satır değeri g veya f den birine eşitse o zaman yeni bir rastgele değer seçsin. rastgele seçilen değer en fazla iki kere yazılabilsin. eğer bir kere seçildi sadece bir kere yazılabildi yine de bir daha seçilmesin. Böyle bir şartı nasıl sağlayabilirm?

pitchoute · 7 Mart 2025

Yanlış anlamadıysam şu şekilde bir kod işinize yarayacaktır. Revize edilmesi gereken kısımlar varsa belirtilseniz yine düzenlemeye çalışırım. Mantık şu şekilde;
D3 hücresinden başlayarak, D sütunundaki verileri rastgele seçiyoruz. Eğer seçilen değerin E sütunundaki değeri, F ve G sütunlarındaki değerlerle eşleşiyorsa, yeni bir rastgele değer seçiyoruz. Eğer E sütunundaki değer, F ve G sütunlarındaki değerlere eşit değilse, rastgele seçilen değeri P sütununa yazıyoruz. Aynı değer sadece bir kez yazabiliyoruz. Her değer en fazla iki kez yazılabiliyor.

Kod:

Option Explicit

Sub RastgeleVeriYazdir()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim randomIndex As Long
    Dim selectedValues As Collection
    Dim valueToCheck As Variant
    Dim eValue As Variant, gValue As Variant, fValue As Variant
    Dim pRow As Long
    Dim count As Integer

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    Set selectedValues = New Collection

    pRow = 3

    Do While pRow <= lastRow
        Randomize ' Rastgele sayılar için
        randomIndex = Int((lastRow - 3 + 1) * Rnd + 3)
        valueToCheck = ws.Cells(randomIndex, "D").Value
        On Error Resume Next
        selectedValues.Add valueToCheck, CStr(valueToCheck)
        On Error GoTo 0
        If selectedValues.Count > 0 Then
            count = 0
            For i = 1 To selectedValues.Count
                If selectedValues(i) = valueToCheck Then count = count + 1
            Next i
        End If
       
        If count <= 2 Then
            eValue = ws.Cells(randomIndex, "E").Value
            gValue = ws.Cells(randomIndex, "G").Value
            fValue = ws.Cells(randomIndex, "F").Value

            If eValue <> gValue And eValue <> fValue Then
                ws.Cells(pRow, "P").Value = valueToCheck
                pRow = pRow + 1
            End If
        End If
    Loop
End Sub

ghostnova · Cumartesi saat 15:37'de

pitchoute' Alıntı:
Yanlış anlamadıysam şu şekilde bir kod işinize yarayacaktır. Revize edilmesi gereken kısımlar varsa belirtilseniz yine düzenlemeye çalışırım. Mantık şu şekilde;
D3 hücresinden başlayarak, D sütunundaki verileri rastgele seçiyoruz. Eğer seçilen değerin E sütunundaki değeri, F ve G sütunlarındaki değerlerle eşleşiyorsa, yeni bir rastgele değer seçiyoruz. Eğer E sütunundaki değer, F ve G sütunlarındaki değerlere eşit değilse, rastgele seçilen değeri P sütununa yazıyoruz. Aynı değer sadece bir kez yazabiliyoruz. Her değer en fazla iki kez yazılabiliyor.

Kod:

Option Explicit Sub RastgeleVeriYazdir() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim randomIndex As Long Dim selectedValues As Collection Dim valueToCheck As Variant Dim eValue As Variant, gValue As Variant, fValue As Variant Dim pRow As Long Dim count As Integer Set ws = ThisWorkbook.Worksheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row Set selectedValues = New Collection pRow = 3 Do While pRow <= lastRow Randomize ' Rastgele sayılar için randomIndex = Int((lastRow - 3 + 1) * Rnd + 3) valueToCheck = ws.Cells(randomIndex, "D").Value On Error Resume Next selectedValues.Add valueToCheck, CStr(valueToCheck) On Error GoTo 0 If selectedValues.Count > 0 Then count = 0 For i = 1 To selectedValues.Count If selectedValues(i) = valueToCheck Then count = count + 1 Next i End If If count <= 2 Then eValue = ws.Cells(randomIndex, "E").Value gValue = ws.Cells(randomIndex, "G").Value fValue = ws.Cells(randomIndex, "F").Value If eValue <> gValue And eValue <> fValue Then ws.Cells(pRow, "P").Value = valueToCheck pRow = pRow + 1 End If End If Loop End Sub

Merhaba, rastgele seçilen değer eğer yerleştiği sütunun satır değerindeki h satırınının değeri değişmiyorsa tekrar yazdırmak istiyorum. Yanı h2 ve h3 değeri aynıysa p2 ve p3 e aynı rastgele değer yazılsın eğer h2 ve h3 değeri farklıysa o zaman yeni rastgele değer seçsin. eski rastgele değer bi kere yazılsın bir daha yazılmasın. Teşekkürler

pitchoute · Pazar saat 10:59'de

Merhaba, şu şekilde dener misiniz;

Kod:

Option Explicit

Sub RastgeleVeriYazdir()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim randomIndex As Long
    Dim selectedValues As Collection
    Dim valueToCheck As Variant
    Dim eValue As Variant, gValue As Variant, fValue As Variant
    Dim pRow As Long
    Dim count As Integer
    Dim hValue As Variant, prevHValue As Variant
    Dim prevRandomValue As Variant
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    Set selectedValues = New Collection

    pRow = 3
    prevHValue = ws.Cells(2, "H").Value

    Do While pRow <= lastRow
        Randomize
        randomIndex = Int((lastRow - 3 + 1) * Rnd + 3)
        valueToCheck = ws.Cells(randomIndex, "D").Value
        
        On Error Resume Next
        selectedValues.Add valueToCheck, CStr(valueToCheck)
        On Error GoTo 0
        
        count = 0
        For i = 1 To selectedValues.Count
            If selectedValues(i) = valueToCheck Then count = count + 1
        Next i
        
        If count <= 2 Then
            eValue = ws.Cells(randomIndex, "E").Value
            gValue = ws.Cells(randomIndex, "G").Value
            fValue = ws.Cells(randomIndex, "F").Value
            hValue = ws.Cells(randomIndex, "H").Value

            If eValue <> gValue And eValue <> fValue Then
                If hValue = prevHValue Then
                    ws.Cells(pRow, "P").Value = prevRandomValue
                    ws.Cells(pRow + 1, "P").Value = prevRandomValue
                    pRow = pRow + 2
                Else
                    prevRandomValue = valueToCheck
                    prevHValue = hValue
                    ws.Cells(pRow, "P").Value = valueToCheck
                    pRow = pRow + 1
                End If
            End If
        End If
    Loop
End Sub

ghostnova · Pazar saat 13:02'de

pitchoute' Alıntı:

Merhaba, şu şekilde dener misiniz;

Kod:

Option Explicit

Sub RastgeleVeriYazdir()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim randomIndex As Long
    Dim selectedValues As Collection
    Dim valueToCheck As Variant
    Dim eValue As Variant, gValue As Variant, fValue As Variant
    Dim pRow As Long
    Dim count As Integer
    Dim hValue As Variant, prevHValue As Variant
    Dim prevRandomValue As Variant
   
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    Set selectedValues = New Collection

    pRow = 3
    prevHValue = ws.Cells(2, "H").Value

    Do While pRow <= lastRow
        Randomize
        randomIndex = Int((lastRow - 3 + 1) * Rnd + 3)
        valueToCheck = ws.Cells(randomIndex, "D").Value
       
        On Error Resume Next
        selectedValues.Add valueToCheck, CStr(valueToCheck)
        On Error GoTo 0
       
        count = 0
        For i = 1 To selectedValues.Count
            If selectedValues(i) = valueToCheck Then count = count + 1
        Next i
       
        If count <= 2 Then
            eValue = ws.Cells(randomIndex, "E").Value
            gValue = ws.Cells(randomIndex, "G").Value
            fValue = ws.Cells(randomIndex, "F").Value
            hValue = ws.Cells(randomIndex, "H").Value

            If eValue <> gValue And eValue <> fValue Then
                If hValue = prevHValue Then
                    ws.Cells(pRow, "P").Value = prevRandomValue
                    ws.Cells(pRow + 1, "P").Value = prevRandomValue
                    pRow = pRow + 2
                Else
                    prevRandomValue = valueToCheck
                    prevHValue = hValue
                    ws.Cells(pRow, "P").Value = valueToCheck
                    pRow = pRow + 1
                End If
            End If
        End If
    Loop
End Sub

Maalesef önceki yazdığınız kod daha çok yakındı istediğime. 24 veriyi 40 satıra yerleştirmek istiyorum bir de p sütununu ben örnek olarak verdim devamlı olarak son sütunu bulan ve bir yanına verileri yazan dinamik bir program istiyorum. Teşekkürler yine de

rastgele veriyi istenen alanda yazdırma

ghostnova

pitchoute

ghostnova

pitchoute

ghostnova