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

FDUYAR · 13 Aralık 2020

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.

FDUYAR · 13 Aralık 2020

Üstadlar bir el atın lütfen, ingilizce projemiz için bu işe bir çözüm bulmalıyız

Korhan Ayhan · 13 Aralık 2020

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

FDUYAR · 14 Aralık 2020

Ü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 · 14 Aralık 2020

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 · 14 Aralık 2020

Kod:

Sayi = WorksheetFunction.RandBetween(1, 200)

Yerine,

Kod:

Sayi = WorksheetFunction.RandBetween(1, Cells(Rows.Count, 1).End(3).Row)

Kullanabilirsiniz.

FDUYAR · 25 Ocak 2021

Korhan Ayhan' Alıntı:

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.

FDUYAR · 25 Ocak 2021

@Korhan Ayhan @veyselemre
zaman ayırdığınız için teşekkürler

Korhan Ayhan · 25 Ocak 2021

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

FDUYAR · 25 Ocak 2021

Korhan Ayhan' Alıntı:

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 · 25 Ocak 2021

B660. satıra kadar devam edecekse tekrar durumu olacaktır. Çünkü 500 satır veriniz var.

FDUYAR · 25 Ocak 2021

Korhan Ayhan' Alıntı:
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 · 25 Ocak 2021

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

FDUYAR · 25 Ocak 2021

@Korhan Ayhan teşekkür ederim çalıştı sorun yok.

FDUYAR · 18 Aralık 2021

@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 · 18 Aralık 2021

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.

FDUYAR · 18 Aralık 2021

Korhan Ayhan' Alıntı:
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 · 19 Aralık 2021

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)

FDUYAR · 19 Aralık 2021

teşekkürler hallettim...

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

FDUYAR

FDUYAR

Korhan Ayhan

Administrator

FDUYAR

Korhan Ayhan

Administrator

veyselemre

Özel Üye

FDUYAR

FDUYAR

Korhan Ayhan

Administrator

FDUYAR

Korhan Ayhan

Administrator

FDUYAR

Korhan Ayhan

Administrator

FDUYAR

FDUYAR

Korhan Ayhan

Administrator

FDUYAR

Korhan Ayhan

Administrator

FDUYAR