Sütundan belirtilen sayı kadar hücre seçimi

Katılım
2 Şubat 2014
Mesajlar
717
Excel Vers. ve Dili
2007 Türkçe
Merhaba arkadaşlar.
"A2:A11" aralığından "C1" de ki sayı kadar
veriyi benzersiz olacak şekilde rastgele seçip
"B" sütunu verisi ile beraber"E4:F4" ten itibaren
yazdırmak istiyorum. Bu hususta yardımlarınızı bekliyorum.
Teşekkür ederim.
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
3,073
Excel Vers. ve Dili
2007 Türkçe
Merhaba,
Aşağıdaki kodu dener misiniz?
Kod:
Sub kod()
Dim lim As Integer, a As Integer, b As Integer
Dim dz As Variant
Dim x1 As String, x2 As String
lim = Range("C1").Value
dz = Range("A2:B11")
If UBound(dz) >= lim Then
    Range("E4").Resize(UBound(dz), 2).ClearContents
    For a = LBound(dz) To UBound(dz)
        b = Int(Rnd() * UBound(dz) + 1)
        x1 = dz(a, 1)
        x2 = dz(a, 2)
        dz(a, 1) = dz(b, 1)
        dz(a, 2) = dz(b, 2)
        dz(b, 1) = x1
        dz(b, 2) = x2
    Next
    For a = 1 To lim
        Cells(a + 3, "E") = dz(a, 1)
        Cells(a + 3, "F") = dz(a, 2)
    Next
Else
    MsgBox UBound(dz) & " veya daha küçük bir sayı giriniz."
End If
End Sub
 
Katılım
2 Şubat 2014
Mesajlar
717
Excel Vers. ve Dili
2007 Türkçe
Merhabalar;
Korhan Hocam benzersizden kastım
A2:A11 aralığında aynı veriden bir den fazla var ise
sadece bir tanesi gitsin idi. Ömer Beyin yaptığı kod maalesef
bu kontrolü yapmıyor.

Ömer Bey ellerinize emeğinize sağlık.
Teşekkür ederim. Acaba aktardığı verileri kontrol etme
durumu olabilir mi kodun.
A2:A11 de aynı veri türü bir den fazla ise;
Seçim yaptırdığımızda sadece bu verinin bir tanesini seçebilir mi ?
Birde A2:A11 alanında boş hücre var ise boş hücreyi seçmemesi
gerekiyor.

Bunun haricinde kod kusursuz.
 
Son düzenleme:

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
3,073
Excel Vers. ve Dili
2007 Türkçe
Tekrar merhaba,
Deneyiniz...
Rich (BB code):
Sub Kod()
Dim lim As Integer, a As Integer, b As Integer, son As Integer
Dim dz1 As Variant, dz2 As Variant
Dim x1 As String, x2 As String, mesaj As String
Dim s As Object
lim = Range("C1").Value
Set s = CreateObject("Scripting.Dictionary")
For a = 2 To 11
    If Not s.exists(Cells(a, "A").Value) And Cells(a, "A").Value <> "" Then
        s.Add Cells(a, "A").Value, Cells(a, "B").Value
    End If
Next
dz1 = s.keys
dz2 = s.items
If UBound(dz1) < lim - 1 Then
    mesaj = UBound(dz1) + 1 & " benzersiz veri bulunmaktadır." & vbLf & _
            "Bu sebeple sadece " & UBound(dz1) + 1 & " veri listelendi."
    son = UBound(dz1)
Else
    mesaj = UBound(dz1) + 1 & " benzersiz veri bulundu." & vbLf & _
            lim & " adet veri listelendi."
    son = lim - 1
End If

Range("E4:F13").ClearContents
Randomize
For a = LBound(dz1) To UBound(dz1)
    b = Int(Rnd() * UBound(dz1) + 1)
    x1 = dz1(a)
    x2 = dz2(a)
    dz1(a) = dz1(b)
    dz2(a) = dz2(b)
    dz1(b) = x1
    dz2(b) = x2
Next
For a = 0 To son
    Cells(a + 4, "E") = dz1(a)
    Cells(a + 4, "F") = dz2(a)
Next
MsgBox "Bitti" & vbLf & mesaj
End Sub
 
Son düzenleme:
Katılım
2 Şubat 2014
Mesajlar
717
Excel Vers. ve Dili
2007 Türkçe
Ömer Bey, emekleriniz için teşekkür ederim sağolun.
benzersiz aktarma işlemi tamam
lakin boş hücre aktarmaya devam ediyor.
 
Katılım
2 Şubat 2014
Mesajlar
717
Excel Vers. ve Dili
2007 Türkçe
Tek kelime ile harika olmuş.
Ömer Bey ellerinize sağlık.

Hoşgörünüze sığınarak bir istirhamım daha olacak.
Yine A2:A11 aralığındaki verilerimizden C1 deki sayı kadar.
Benzersiz ve boş hücre seçmeyecek sekilde seçim yapılacak.
Lakin bu kez seçimler taşınmayıp. B sütununda yapılan seçimlerin
hizasına "X" işareti koyacak şekilde bir alternatif yapabilir miyiz acaba
bu kodu da başka bir dosya da kullanacağım.
 

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
3,073
Excel Vers. ve Dili
2007 Türkçe
Buyurunuz...
Kod:
Sub Kod_2()
Dim lim As Integer, a As Integer, b As Integer, son As Integer
Dim dz1 As Variant, dz2 As Variant
Dim x1 As String, x2 As String, mesaj As String
Dim s As Object
lim = Range("C1").Value
Set s = CreateObject("Scripting.Dictionary")
For a = 2 To 11
    If Not s.exists(Cells(a, "A").Value) And Cells(a, "A").Value <> "" Then
        s.Add Cells(a, "A").Value, Cells(a, "B").Address
    End If
Next
dz1 = s.keys
dz2 = s.items
If UBound(dz1) < lim - 1 Then
    mesaj = UBound(dz1) + 1 & " benzersiz veri bulunmaktadır." & vbLf & _
            "Bu sebeple sadece " & UBound(dz1) + 1 & " veri listelendi."
    son = UBound(dz1)
Else
    mesaj = UBound(dz1) + 1 & " benzersiz veri bulundu." & vbLf & _
            lim & " adet veri listelendi."
    son = lim - 1
End If

Range("B2:B11").ClearContents
Randomize
For a = LBound(dz1) To UBound(dz1)
    b = Int(Rnd() * UBound(dz1) + 1)
    x1 = dz1(a)
    x2 = dz2(a)
    dz1(a) = dz1(b)
    dz2(a) = dz2(b)
    dz1(b) = x1
    dz2(b) = x2
Next
For a = 0 To son
    Range(dz2(a)).Value = "X"
Next
MsgBox "Bitti" & vbLf & mesaj
End Sub
 
Üst