rastgele veriyi istenen alanda yazdırma

Katılım
7 Mart 2025
Mesajlar
3
Excel Vers. ve Dili
excel vba
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?
 
Katılım
11 Temmuz 2024
Mesajlar
234
Excel Vers. ve Dili
Excel 2021 Türkçe
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
 
Katılım
7 Mart 2025
Mesajlar
3
Excel Vers. ve Dili
excel vba
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
 
Katılım
11 Temmuz 2024
Mesajlar
234
Excel Vers. ve Dili
Excel 2021 Türkçe
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
 
Katılım
7 Mart 2025
Mesajlar
3
Excel Vers. ve Dili
excel vba
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
 
Üst