A sütunundaki verilerden rastgele 200 tanesini seçerek b sütununda birleştirme

Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
Merhaba arkadaşlar,

A sütunundaki verilerden rastgele 200 tanesini seçerek b sütununda birleştirmeyi nasıl yapabilirim?

A sütununda 500 satır var ve her bir satırda bir cümle var. Bu 500 satır içerisinden rastgele 200 satırın seçilerek b sütünunda bir makale haline gelmesini istiyorum.
Yardımcı olabilir misiniz.
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
Üstadlar bir el atın lütfen, ingilizce projemiz için bu işe bir çözüm bulmalıyız
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Rastgele_Makale_Olustur()
    Dim Dizi As Object, Sayi As Byte, Say As Byte
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Range("B1").ClearContents
    
    ReDim Liste(1 To 200)
    
10  Randomize Timer
    Sayi = WorksheetFunction.RandBetween(1, 200)

    If Say = 200 Then GoTo 20
    
    If Not Dizi.Exists(Sayi) Then
        Say = Say + 1
        Liste(Say) = Cells(Sayi, 1)
        If Say < 200 Then GoTo 10
    Else
        Dizi.Add Sayi, Nothing
        GoTo 10
    End If

20  Range("B1") = Join(Liste, vbLf)

    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
Üstad kod çalıştı teşekkür ederim ilginiz için...
ufak bi düzenleme yapabilir miyiz?
şu an bu kod sadece b1 sütununa rastgele 200 satırı getiriyor. Bunu B80 sütununa kadar yapabilir miyiz... Yani b80 sütununa kadar aynı işlemi yapsın.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Rastgele_Makale_Olustur()
    Dim Dizi As Object, Sayi As Byte, Say As Byte, X As Byte
        
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Range("B1:B80").ClearContents
    
    ReDim Liste(1 To 200)
    ReDim Makale(1 To 80, 1 To 1)
    
    For X = 1 To 80
10      Randomize Timer
        Sayi = WorksheetFunction.RandBetween(1, 200)
    
        If Say = 200 Then GoTo 20
        
        If Not Dizi.Exists(Sayi) Then
            Say = Say + 1
            Liste(Say) = Cells(Sayi, 1)
            If Say < 200 Then GoTo 10
        Else
            Dizi.Add Sayi, Nothing
            GoTo 10
        End If
    
20      Makale(X, 1) = Join(Liste, vbLf)
        Dizi.RemoveAll
        ReDim Liste(1 To 200)
        Say = 0
    Next
    
    Range("B1").Resize(X - 1, 1) = Makale
    
    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod:
Sayi = WorksheetFunction.RandBetween(1, 200)
Yerine,
Kod:
Sayi = WorksheetFunction.RandBetween(1, Cells(Rows.Count, 1).End(3).Row)
Kullanabilirsiniz.
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
Deneyiniz.

C++:
Option Explicit

Sub Rastgele_Makale_Olustur()
    Dim Dizi As Object, Sayi As Byte, Say As Byte, X As Byte
       
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Range("B1:B80").ClearContents
   
    ReDim Liste(1 To 200)
    ReDim Makale(1 To 80, 1 To 1)
   
    For X = 1 To 80
10      Randomize Timer
        Sayi = WorksheetFunction.RandBetween(1, 200)
   
        If Say = 200 Then GoTo 20
       
        If Not Dizi.Exists(Sayi) Then
            Say = Say + 1
            Liste(Say) = Cells(Sayi, 1)
            If Say < 200 Then GoTo 10
        Else
            Dizi.Add Sayi, Nothing
            GoTo 10
        End If
   
20      Makale(X, 1) = Join(Liste, vbLf)
        Dizi.RemoveAll
        ReDim Liste(1 To 200)
        Say = 0
    Next
   
    Range("B1").Resize(X - 1, 1) = Makale
   
    Set Dizi = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Hocam merhaba,
Ben listede bazı değişiklikler yaptım sonuç itibari ile de sizin kodları düzenledim fakat bir türlü istediğim sonucu elde edemedim...
Usta eli değmesi gerekiyor :)

A sutununda 500 satır var, Bu 500 satır içerisinden rastgele 30 tanesini seçerek B1 Hücresinin içerisinde birleştirmesini istiyorum.
Bu işlemide B660'a kadar da yapmasını istiyorum . Değerli yardımlarınızı rica ederim.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++:
Option Explicit

Sub Rastgele_Makale_Olustur()
    Dim Dizi As Object, Sayi As Byte, Say As Byte, X As Integer
      
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    Range("B1:B660").ClearContents
  
    ReDim Liste(1 To 30)
    ReDim Makale(1 To 660, 1 To 1)
  
    For X = 1 To 660
10      Randomize Timer
        Sayi = WorksheetFunction.RandBetween(1, 30)
  
        If Say = 30 Then GoTo 20
      
        If Not Dizi.Exists(Sayi) Then
            Say = Say + 1
            Liste(Say) = Cells(Sayi, 1)
            If Say < 30 Then GoTo 10
        Else
            Dizi.Add Sayi, Nothing
            GoTo 10
        End If
  
20      Makale(X, 1) = Join(Liste, vbLf)
        Dizi.RemoveAll
        ReDim Liste(1 To 30)
        Say = 0
    Next
  
    Range("B1").Resize(X - 1, 1) = Makale
  
    Set Dizi = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
Deneyiniz.

C++:
Option Explicit

Sub Rastgele_Makale_Olustur()
    Dim Dizi As Object, Sayi As Byte, Say As Byte, X As Integer
     
    Set Dizi = CreateObject("Scripting.Dictionary")
 
    Range("B1:B660").ClearContents
 
    ReDim Liste(1 To 30)
    ReDim Makale(1 To 660, 1 To 1)
 
    For X = 1 To 660
10      Randomize Timer
        Sayi = WorksheetFunction.RandBetween(1, 30)
 
        If Say = 30 Then GoTo 20
     
        If Not Dizi.Exists(Sayi) Then
            Say = Say + 1
            Liste(Say) = Cells(Sayi, 1)
            If Say < 30 Then GoTo 10
        Else
            Dizi.Add Sayi, Nothing
            GoTo 10
        End If
 
20      Makale(X, 1) = Join(Liste, vbLf)
        Dizi.RemoveAll
        ReDim Liste(1 To 30)
        Say = 0
    Next
 
    Range("B1").Resize(X - 1, 1) = Makale
 
    Set Dizi = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Hızlı cevabınız için teşekkür ederim @Korhan Ayhan

fakat kodda sorunlar var...
Ben A sutununda ki 500 satır içerisinde rastgele 30 satırı seçmesini istiyorum... fakat bu kod ilk 30 satır içerisinden rastgele seçim yapıyor.
diğer bir sorunda aynı satırı birden fazla kere seçebiliyor, seçtiği bir satırı bir daha seçmemesi gerekiyor.

buna göre düzeltebilir miyiz, teşekkürler
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
B660. satıra kadar devam edecekse tekrar durumu olacaktır. Çünkü 500 satır veriniz var.
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
B660. satıra kadar devam edecekse tekrar durumu olacaktır. Çünkü 500 satır veriniz var.
@Korhan Ayhan hücre içerisinde tekrar olmasın demek istedim. Yani b1 hücresinin içerisinde A sutunundaki 500 satırdan rastgele 30 adetini seçtiği için seçerken aynı şeyi iki kere seçmesin istiyoruz.

diğer taraftan önceki mesajımda belirttiğim gibi şu an mevcut kod 500 satır içerisinden 30 adet seçmek yerine ilk 30 satırdan rastgele 30 adeti seçiyoru
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu kodu deneyiniz.

C++:
Option Explicit

Sub Rastgele_Makale_Olustur()
    Dim Dizi As Object, Sayi As Integer, Say As Byte, X As Integer
       
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Range("B1:B660").ClearContents
   
    ReDim Liste(1 To 30)
    ReDim Makale(1 To 660, 1 To 1)
   
    For X = 1 To 660
10      Randomize Timer
        Sayi = WorksheetFunction.RandBetween(1, 500)
   
        If Say = 30 Then GoTo 20
       
        If Not Dizi.Exists(Sayi) Then
            Say = Say + 1
            Liste(Say) = Cells(Sayi, 1)
            Dizi.Add Sayi, Nothing
            If Say < 30 Then GoTo 10
        Else
            GoTo 10
        End If
   
20      Makale(X, 1) = Join(Liste, vbLf)
        Dizi.RemoveAll
        ReDim Liste(1 To 30)
        Say = 0
    Next
   
    Range("B1").Resize(X - 1, 1) = Makale
   
    Set Dizi = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
@Korhan Ayhan hocam merhaba,
Sizden ufak bir revize istesem musait olduğunuzda bakar mısınız...

Bana en son yazdığınız kodda :
A sutununda 500 satır var, Bu 500 satır içerisinden rastgele 30 tanesini seçerek B1 Hücresinin içerisinde birleştiriyordu..
Bu işlemi B660 kadar tekrarlıyordu...

Bu işlemi nasıl çoklarız ?
Yani benzer 500 verilik satır C sutununda da var, ve C sutununda da aynı işlemi yapmasını ve D sutununda 660'kadar bunları birleştirmesini istiyorum.

Özetle..
A Sutunundaki veriler B sutununda,

C Sutunundaki veriler D sutununda,

E Sutunundaki veriler F sutununda,...

Bu 3 işlemi tek kod ile nasıl yapabiliriz?

Değerli desteklerinizi bekliyorum, teşekkürler.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ben olsam beni beklemezdim.

Aynı koddan iki adet daha kopyalardım. Sonra sütun bilgilerini ve makroların isimlerini değiştirip kullanırdım.

Sonra hepsini tek makro ile çalıştırıp sonuca giderdim.

Örnek;

Sub Hepsini_Calistir()
Kod1
Kod2
Kod3
End Sub

Siz Kod1, Kod2, Kod3 yazan yere kendi verdiğiniz makro isimlerini yazarsınız.

Bence deneyin birşey kaybetmezsiniz.
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
Ben olsam beni beklemezdim.

Aynı koddan iki adet daha kopyalardım. Sonra sütun bilgilerini ve makroların isimlerini değiştirip kullanırdım.

Sonra hepsini tek makro ile çalıştırıp sonuca giderdim.

Örnek;

Sub Hepsini_Calistir()
Kod1
Kod2
Kod3
End Sub

Siz Kod1, Kod2, Kod3 yazan yere kendi verdiğiniz makro isimlerini yazarsınız.

Bence deneyin birşey kaybetmezsiniz.
Hocam, kodlamada A Sütunu ile ilgili bir veri göremedim, görebilsem A sütunu yerine C ve E sutunlarını yerleştirip alt alta eklemeyi deneyecektim...
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Biraz gayret gösterirseniz çözebilirsiniz.

Aşağıdaki satırda parantez içindeki 1 değeri A sütununu ifade etmektedir. Sanırım gerisini siz halledersiniz.

Liste(Say) = Cells(Sayi, 1)
 
Katılım
16 Mart 2007
Mesajlar
46
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
13.12.2022
teşekkürler hallettim...
 
Üst