[Yardım]  Aylık Veriler İçerisinden Örneklem Seçme

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Aylık Veriler İçerisinden Örneklem Seçme

İleti#1)  EA7MARMARA » 21 May 2019 13:48

Herkese İyi Günler,

Aşağıda detaylarını verdiğim bir makroya ihtiyacım var. İşin İçinden Çıkamadım. Bu Konuda da Yeniyim.

Mevcut Excelimde 3 Sayfa Var. Excel Dosyasını Yükledim.
rneklem Makrosu.zip


1-Popülasyon, 2-Örneklem Seçim, 3-Örneklem Listesi


"Popülasyon" Sayfasına Tarih A Hücresinde olacak Şekilde Eldeki Tüm Verileri Yapıştırıyoruz.

Veri Yapıştırdıktan Sonra "Örneklem Seçim" Sayfasında Her Aya Ait Kayıt Sayısı (Popülasyon Sayısı) ve O Aydan Seçilmesi Gereken Örnek Sayısı (Seçilecek Örnek Sayısı) Otomatik Olarak Geliyor.

Elimizde 12 Aylık Veri Var. Her Zaman 12 Aylık Veri Olmayabilir Burası Önemli, Veri Olmayan Ayın Karşısında 0 oluyor.

Hangi Aydan Kaç Örnek Seçileceği Örneklem Seçim Sayfasının F Sütunundan Alınacak Şekilde

İstenen Makro;

Ocak Ayı Popülasyon 100 - Seçilecek Örnek Sayısı 5 ise > Popülasyon Sayfasındaki 100 adet Ocak Ayı Verileri İçerisinden Rastgele 5 Adedini Seç, Örneklem Listesi Sayfasına Ekle (Popülasyondaki Tüm Sütun Başlıkları ve Verileri ile Beraber, Kısıtlama Yok)

Şubat Ayı Popülasyon 250 - Seçilecek Örnek Sayısı 12 ise >Popülasyon Sayfasındaki Şubat Ayı Verileri İçerisinden Rastgele 12 Adedini Seç, Örneklem Listesinde Ocak Ayındaki Son kaydın Altından İtibaren Sayfaya Ekle (Popülasyondaki Tüm Sütun Başlıkları ve Verileri ile Beraber, Kısıtlama Yok)

Bu şekilde 12 Ay için de çalışıp ana kütle içerisinden örnekleri otomatik olarak seçecek.


Önemli Nokta: Her Aydan Seçilecek Örnek Sayısı "Örneklem Seçim" Sayfasının F Sütununda yer alıyor ve değişkenlik gösteriyor.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
EA7MARMARA
 
Kayıt: 21 May 2019 13:22
Meslek: Müfettiş
Yaş: 30
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#2)  EA7MARMARA » 23 May 2019 14:56

Yardım edebilecek yok mu acaba , elimde çalışan bir makro var ancak, popülasyon sayfasının a hücresindekilerden boyalı olanları atıyor. benim istediğim boyamaya gerek kalmadan ve benim seçmeme gerek kalmadan diğer sayfaya rastgele otomatik atması.

Kod: Tümünü seç
Sub OrneklemKopyala()
    Dim P As Worksheet, O As Worksheet, S As Worksheet
    Dim bul As Range, satır As Long
    Dim LMonth As Integer
    Set P = Sheets("Popülasyon")
    Set O = Sheets("Örneklem Listesi")
    Set S = Sheets("Örneklem Seçim")
    Application.ScreenUpdating = False
    Sheets("Örneklem Listesi").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    For Each bul In P.Range("A2:A" & P.Range("A65536").End(3).Row)
    If bul.Interior.Color <> vbWhite Then
    satır = satır + 1
    bul.EntireRow.Copy
    O.Select
    Cells(satır + 1, 1).PasteSpecial
    P.Rows(1).Copy
    O.Select
    O.Rows(1).Select
    O.Paste
    End If
    Next bul
    [a1].Select
    Rows("1:1").Select
    Selection.Font.Bold = True
    O.Select
    Rows("1:1").EntireRow.AutoFit
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "İnceleme"
    O.Select
    Columns("B:B").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        Selection.NumberFormat = "General"
        Cells.Select
    Cells.EntireColumn.AutoFit
    End With
    O.Select
    Columns("A:A").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Test Formu").Select
    ActiveSheet.Unprotect
    Range("Q11:V11").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(AND('Örneklem Seçim'!R[-4]C[-15]>0,(COUNT('Örneklem Listesi'!C1)-((COUNTA('Örneklem Listesi'!C2))-1))>0),""Örneklem Listesinde İnceleme Sonucu Yazılmayan Örnek Bulunmaktadır."","""")"
    Range("Q12:V12").Select
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    Sheets("Örneklem Listesi").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Kullanıcı avatarı
EA7MARMARA
 
Kayıt: 21 May 2019 13:22
Meslek: Müfettiş
Yaş: 30
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#3)  EA7MARMARA » 23 May 2019 15:03

Bir üstteki mesajı düzenleyemiyorum. Kodu hatalı eklemişim. Doğrusu aşağıda


Kod: Tümünü seç
Sub OrneklemKopyala()
    Dim P As Worksheet, O As Worksheet
    Dim bul As Range, satır As Long
    Set P = Sheets("Popülasyon")
    Set O = Sheets("Örneklem Listesi")
    Application.ScreenUpdating = False
    Sheets("Örneklem Listesi").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    For Each bul In P.Range("A2:A" & P.Range("A65536").End(3).Row)
    If bul.Interior.Color <> vbWhite Then
    satır = satır + 1
    bul.EntireRow.Copy
    O.Select
    Cells(satır + 1, 1).PasteSpecial
    P.Rows(1).Copy
    O.Select
    O.Rows(1).Select
    O.Paste
    End If
    Next bul
    [a1].Select
    Rows("1:1").Select
    Selection.Font.Bold = True
    O.Select
    Rows("1:1").EntireRow.AutoFit
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "İnceleme"
    O.Select
    Columns("B:B").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
        Selection.NumberFormat = "General"
        Cells.Select
    Cells.EntireColumn.AutoFit
    End With
    O.Select
    Columns("A:A").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Test Formu").Select
    ActiveSheet.Unprotect
    Range("Q11:V11").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(AND('Örneklem Seçim'!R[-4]C[-15]>0,(COUNT('Örneklem Listesi'!C1)-((COUNTA('Örneklem Listesi'!C2))-1))>0),""Örneklem Listesinde İnceleme Sonucu Yazılmayan Örnek Bulunmaktadır."","""")"
    Range("Q12:V12").Select
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
    Sheets("Örneklem Listesi").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Kullanıcı avatarı
EA7MARMARA
 
Kayıt: 21 May 2019 13:22
Meslek: Müfettiş
Yaş: 30
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#4)  Feyzullah » 23 May 2019 17:38

ADO kodu ile yapılmış alternatif çalışma.

Kod: Tümünü seç
Sub exceldestek()
Dim ol As Worksheet
Set P 
= Worksheets("Popülasyon")
Set os = Worksheets("Örneklem Seçim")
Set ol = Worksheets("Örneklem Listesi")
ol.Cells.ClearContents
    Set con 
= VBA.CreateObject("adodb.Connection")
    Set rs = VBA.CreateObject("adodb.Recordset")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook
.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
            i = 2: sat = 1
            While i 
<= 13
                sorgu 
= "select * from[Popülasyon$] where format([İşlem Tarihi],'mmmm') = '" & os.Cells(i, "d") & "' and [İşlem Tarihi] is not null  "
                rs.Open sorgu, con, 1, 1
                If rs
.RecordCount > 0 Then
                    On Error Resume Next
                        For j 
= 0 To rs.Fields.Count
                            ol
.Cells(1, j + 1).Value = rs.Fields(j).Name
                        Next j
                    On Error GoTo 0
                    say 
= 0
                    Do While Not rs
.EOF
                        say 
= say + 1: sat = sat + 1
                        dizi 
= Array(CDate(rs(0).Value), rs(1).Value, CDate(rs(2).Value), rs(3).Value, rs(4).Value, rs(5).Value, rs(6).Value, rs(7).Value, rs(8).Value, rs(9).Value, rs(10).Value, rs(11).Value, rs(12).Value, rs(13).Value, rs(14).Value, rs(15).Value, rs(16).Value)
                            ol.Range("A" & sat & ":Q" & sat) = dizi
                                If os
.Cells(i, "F") = say Then Exit Do
                    rs
.movenext
                    Loop
                End If
                rs
.Close
            i 
= i + 1
            Wend
        con
.Close
    Set con 
= Nothing
    Set rs 
= Nothing
End Sub
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
Feyzullah
Site Dostu
 
Adı Soyadı:mete han
Kayıt: 18 Ekm 2011 08:30
İleti: 538
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: OSMANİYE

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#5)  EA7MARMARA » 23 May 2019 20:13

metehan8001 yazdı:ADO kodu ile yapılmış alternatif çalışma.

Kod: Tümünü seç
Sub exceldestek()
Dim ol As Worksheet
Set P 
= Worksheets("Popülasyon")
Set os = Worksheets("Örneklem Seçim")
Set ol = Worksheets("Örneklem Listesi")
ol.Cells.ClearContents
    Set con 
= VBA.CreateObject("adodb.Connection")
    Set rs = VBA.CreateObject("adodb.Recordset")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook
.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
            i = 2: sat = 1
            While i 
<= 13
                sorgu 
= "select * from[Popülasyon$] where format([İşlem Tarihi],'mmmm') = '" & os.Cells(i, "d") & "' and [İşlem Tarihi] is not null  "
                rs.Open sorgu, con, 1, 1
                If rs
.RecordCount > 0 Then
                    On Error Resume Next
                        For j 
= 0 To rs.Fields.Count
                            ol
.Cells(1, j + 1).Value = rs.Fields(j).Name
                        Next j
                    On Error GoTo 0
                    say 
= 0
                    Do While Not rs
.EOF
                        say 
= say + 1: sat = sat + 1
                        dizi 
= Array(CDate(rs(0).Value), rs(1).Value, CDate(rs(2).Value), rs(3).Value, rs(4).Value, rs(5).Value, rs(6).Value, rs(7).Value, rs(8).Value, rs(9).Value, rs(10).Value, rs(11).Value, rs(12).Value, rs(13).Value, rs(14).Value, rs(15).Value, rs(16).Value)
                            ol.Range("A" & sat & ":Q" & sat) = dizi
                                If os
.Cells(i, "F") = say Then Exit Do
                    rs
.movenext
                    Loop
                End If
                rs
.Close
            i 
= i + 1
            Wend
        con
.Close
    Set con 
= Nothing
    Set rs 
= Nothing
End Sub



Çok teşekkürler, elinize sağlık. Tam istediğim gibi çok güzel çalışıyor.
Bir de Popülasyon Sayfasındaki En Baştaki Sütun formülasyonda "İşlem Tarihi" Olarak Alınmış, bunun yerine o hücreye referans vermemiz mümkün mü, çünkü verinin alındığı ekrana göre A1 hücresinin ismi tarih, işlem tarihi, x tarihi vs. şeklinde değişecek, dolayısıyla formül çalışmayacak.
Kullanıcı avatarı
EA7MARMARA
 
Kayıt: 21 May 2019 13:22
Meslek: Müfettiş
Yaş: 30
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#6)  Feyzullah » 23 May 2019 21:20

Olayı anlamadım, bunun yerine örnek bir dosya ile gösterirmisin.
Kullanıcı avatarı
Feyzullah
Site Dostu
 
Adı Soyadı:mete han
Kayıt: 18 Ekm 2011 08:30
İleti: 538
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: OSMANİYE

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#7)  EA7MARMARA » 24 May 2019 21:43

metehan8001 yazdı:Olayı anlamadım, bunun yerine örnek bir dosya ile gösterirmisin.


Merhaba, dosyayı ekledim. Comment'e istenen değişikliği yazdım.

rneklem Makrosu Değişiklik.zip
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
EA7MARMARA
 
Kayıt: 21 May 2019 13:22
Meslek: Müfettiş
Yaş: 30
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Aylık Veriler İçerisinden Örneklem Seçme

İleti#8)  Feyzullah » 24 May 2019 22:19

EA7MARMARA yazdı:
metehan8001 yazdı:Olayı anlamadım, bunun yerine örnek bir dosya ile gösterirmisin.


Merhaba, dosyayı ekledim. Comment'e istenen değişikliği yazdım.



Bahsettiğiniz Comment i bulamadım, ekli dosyada yoktu ama ben anladığım kadarıyla kodları revize yaptım. Sütun başlıklarını istediğiniz gibi değiştire bilirsiniz. Aşağıdaki kodu deneyin.

Kod: Tümünü seç
Sub exceldestek()
Dim ol As Worksheet
Set P 
= Worksheets("Popülasyon")
Set os = Worksheets("Örneklem Seçim")
Set ol = Worksheets("Örneklem Listesi")
ol.Cells.ClearContents
    Set con 
= VBA.CreateObject("adodb.Connection")
    Set rs = VBA.CreateObject("adodb.Recordset")
        con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook
.FullName & ";extended properties=""Excel 12.0;hdr=No"""
            i = 2: sat = 1
            While i 
<= 13
                sorgu 
= "select * from[Popülasyon$A2:Q] where format(f1,'mmmm') = '" & os.Cells(i, "d") & "' and f1 is not null  "
                rs.Open sorgu, con, 1, 1
                If rs
.RecordCount > 0 Then
                    On Error Resume Next
                        For j 
= 0 To rs.Fields.Count
                            ol
.Cells(1, j + 1).Value = rs.Fields(j).Name
                        Next j
                    On Error GoTo 0
                    say 
= 0
                    Do While Not rs
.EOF
                        say 
= say + 1: sat = sat + 1
                        dizi 
= Array(CDate(rs(0).Value), rs(1).Value, CDate(rs(2).Value), rs(3).Value, rs(4).Value, rs(5).Value, rs(6).Value, rs(7).Value, rs(8).Value, rs(9).Value, rs(10).Value, rs(11).Value, rs(12).Value, rs(13).Value, rs(14).Value, rs(15).Value, rs(16).Value)
                            ol.Range("A" & sat & ":Q" & sat) = dizi
                                If os
.Cells(i, "F") = say Then Exit Do
                    rs
.movenext
                    Loop
                End If
                rs
.Close
            i 
= i + 1
            Wend
        con
.Close
    Set con 
= Nothing
    Set rs 
= Nothing
End Sub
Kullanıcı avatarı
Feyzullah
Site Dostu
 
Adı Soyadı:mete han
Kayıt: 18 Ekm 2011 08:30
İleti: 538
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: OSMANİYE


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 4 misafir

Bumerang - Yazarkafe