Sayfada % oranında harmanlama yaparak verileri başka sayfaya taşımak

[ecaparo]

Ekteki listeden % 20 lik harmanlama (rasgele) yaparak yeni bir çalışma sayfasına bölge bölge ayrı sayfa olarak taşımasını istiyorum
gerçek listemizde 30000 tesisat var her işletme için ayrı ayrı % 20 lik kısım harmanlamam gerekli yardımcı olursanız sevinirim

http://s4.dosya.tc/server2/as9oha/ESIT_RAPOR.xlsx.html
https://yadi.sk/i/nSSGl5WvsqudA

 

[ecaparo]

üstadlar lütfen yardım çıkamadım içinden

 

[ecaparo]

kimse yok mu bir fikir verecek

 

[ecaparo]

arkadaşlar lütfen

 

[Korhan Ayhan]

%20 den kastınız nedir?

Anladığım kadarıyla ilgili bölgedeki kayıt sayısının %20 sini rastgele listelemek istiyorsunuz.

Eğer isteğiniz bu yönde ise aşağıdaki kod işinize yarayacaktır.

Sub LİSTE_OLUŞTUR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Veri_Say As Long
    Dim Aranan As String, Say As Long, Son As Long, Satır As Long, Sayfa As Worksheet
    
    Set S1 = Sheets("LİSTE")
    
    S1.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("AA1"), Unique:=True
    S1.Range("AA2:AA" & Rows.Count).Sort S1.Range("AA1"), xlAscending
    
    Application.DisplayAlerts = False
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    
    Application.DisplayAlerts = True
    
    Randomize
    
    Kayıt_Sayısı = S1.Cells(Rows.Count, "AA").End(3).Row
    
    For X = 2 To Kayıt_Sayısı
        Aranan = S1.Cells(X, "AA")
        Say = VBA.Round(WorksheetFunction.CountIf(S1.Range("C:C"), Aranan) * 0.2, 0)
        If Say > 0 Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Aranan
            Set S2 = ActiveSheet
            S1.Rows(1).Copy S2.Rows(1)
10          Son = S1.Cells(Rows.Count, "A").End(3).Row
            Satır = Int(Rnd() * Son) + 2
            If S1.Cells(Satır, "C") = Aranan Then
                If S1.Cells(Satır, "K") = "" Then
                    Son = S2.Cells(Rows.Count, "A").End(3).Row + 1
                    S1.Cells(Satır, "A").EntireRow.Copy S2.Cells(Son, "A")
                    S1.Cells(Satır, "K") = "X"
                    Veri_Say = Veri_Say + 1
                    If Veri_Say = Say Then
                        GoTo 20
                    Else
                        GoTo 10
                    End If
                Else
                    GoTo 10
                End If
            Else
                GoTo 10
            End If
20          Veri_Say = 0
        End If
    Next
    
    S1.Range("AA:AA").Clear
    S1.Range("K:K").ClearContents

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ecaparo]

Evet korhan bey o bölgedeki kayıt sayısının % 20 kısmı
ellerinize sağlık tam olarak yapmak istediğim buydu .
Sadece şu listeden aktarılan verilerin silmesini nasıl yaparız yani aktardığımız veriler liste sayfasında kalmasın silinsin

 

[Korhan Ayhan]

Silmek için aşağıdaki kodu kullanabilirsiniz.

Sub LİSTE_OLUŞTUR()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Veri_Say As Long
    Dim Aranan As String, Say As Long, Son As Long, Satır As Long, Sayfa As Worksheet
    
    Set S1 = Sheets("LİSTE")
    
    S1.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("AA1"), Unique:=True
    S1.Range("AA2:AA" & Rows.Count).Sort S1.Range("AA1"), xlAscending
    
    Application.DisplayAlerts = False
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    
    Application.DisplayAlerts = True
    
    Randomize
    
    Kayıt_Sayısı = S1.Cells(Rows.Count, "AA").End(3).Row
    
    For X = 2 To Kayıt_Sayısı
        Aranan = S1.Cells(X, "AA")
        Say = VBA.Round(WorksheetFunction.CountIf(S1.Range("C:C"), Aranan) * 0.2, 0)
        If Say > 0 Then
            Sheets.Add , Sheets(Sheets.Count)
            ActiveSheet.Name = Aranan
            Set S2 = ActiveSheet
            S1.Rows(1).Copy S2.Rows(1)
10          Son = S1.Cells(Rows.Count, "A").End(3).Row
            Satır = Int(Rnd() * Son) + 2
            If S1.Cells(Satır, "C") = Aranan Then
                Son = S2.Cells(Rows.Count, "A").End(3).Row + 1
                S1.Cells(Satır, "A").EntireRow.Copy S2.Cells(Son, "A")
                S1.Cells(Satır, "A").EntireRow.Delete
                Veri_Say = Veri_Say + 1
                If Veri_Say = Say Then
                    GoTo 20
                Else
                    GoTo 10
                End If
            Else
                GoTo 10
            End If
20          Veri_Say = 0
        End If
    Next
    
    S1.Range("AA:AA").Clear

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ecaparo]

çok teşekkur ederim Allah razı olsun
elinize sağlık