Veri Gruplarını Buldurma

[nadirornek]

Merhaba;Bugün öğrendim bir grupta en fazla 15 adet bulunuyor 5 adeti 15 adet olarak yükseltebilirmiyiz ?

 

[nadirornek]

Arkadaşlar dosyamın son halini ekledim.Gelen veriler sayfasında E sutunundaki verileri 15 satır açarak oluyor buda zaman alıyor.Gruplarda 2 veride var 3 veride var bunlar arasını açmam gerekiyor en fazla veri 15 adet veri var .Kodu yeniden düzenleye bilirmiyiz.Satır açmadan olabilirmi. Gelen veriler sayfasında veriler arasındaki boş satırları silerek sorunu görebilirsiniz.Dosyada benim görmem gereken yer Ana sayfada C ve D sutunlarında Oluşturdum.Burasınıda Ana sayfada F sutununda veriler gelen veriye göre sıralı olmadığı için ilave boş satırsil ve düşeyara ile oluşturdum.

 

[snx111]

deleted....................

 

[nadirornek]

Sinan bey gerçekten emeğiniz için teşekkürler.Gelen veriler sayfasına yeni veri eklediğimde elle satır sayılarını ayarlamak gerekiyor.Bunu ortadan kaldırırsak gercekten güzel bir çalışma olacak.
Gelen veriler sayfasındaki veriler arasındaki boş sutunlardan silerek sorunu görebilirsiniz.

 

[snx111]

shitf deleted .....

 

[nadirornek]

Sadece 15 verili grubu buluyor diğerlerini bulmuyor.

 

[snx111]

DEleted.............................

 

[snx111]

1 den 15 şe kadar buluyor ???? hatanız olmasın ???

 

[Ömer]

Merhaba,

Alternatif olsun.

1. mesaja eklediğiniz dosyaya göre hazırladım. Veri sınırlaması yoktur.

Sub Rapor()
 
    Dim Sg As Worksheet, Ss As Worksheet, Sa As Worksheet, alan As Range
    Dim art As Long, sat As Long, son As Long, say As Long, deg As Long
    Dim c As Range, d As Range, Adr As String, i As Long, z As Long, sona As Long
 
    Set Sg = Sheets("Gelen Veriler")
    Set Ss = Sheets("Sutun Gruplar")
    Set Sa = Sheets("Ana Sayfa")
 
    Application.ScreenUpdating = False
    Sa.Range("F2:G" & Rows.Count).ClearContents
 
    art = 1
    For i = 1 To WorksheetFunction.CountA(Sg.[H:H]) - 1
        sat = 1
        deg = Sg.Cells(art, "H").End(xlDown).Row
        son = Sg.Cells(deg + 2, "E").End(xlDown).Row
        say = son - deg - 1
        With Ss.Range("A3:AX50")
            Set c = .Find(Sg.Cells(deg + 2, "E"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    Set alan = Ss.Range(Ss.Cells(3, c.Column), Ss.Cells(Rows.Count, c.Column))
                    If WorksheetFunction.CountA(alan) = say Then
                        For z = deg + 3 To son
                            If WorksheetFunction.CountIf(alan, Sg.Cells(z, "E")) > 0 Then
                                sat = sat + 1
                            End If
                        Next z
                    End If
                    If say = sat Then Exit Do
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
        art = deg
        If say = sat Then
            sona = Sa.Cells(Rows.Count, "G").End(xlUp).Row + 1
            Sa.Cells(sona, "F") = Sg.Cells(deg, "H")
            Sa.Cells(sona, "G") = Ss.Cells(2, c.Column)
        End If
    Next i
 
    Application.ScreenUpdating = True
    MsgBox "Aktarım Tamamlandı", , "Bilgi...!"
 
End Sub

Not: Detaylı deneme yapmadım.

 

[snx111]

Şükür ömer bey el attı konuya

Sonu gelmez gibi geliyor bana

 

[Ömer]

Sonu gelmez gibi geliyor bana

Erkekliğin %99 u kaçmaktır.

 

[snx111]

Ömer bey kod sayfayı siliyor mesaj sonrası boş gösteriyor hazır dosya yüklermisiniz

 

[Ömer]

#1. numaralı mesajdaki dosyada mı denediniz? Kodları #1 numaralı dosyaya göre yazmıştım.

 

[snx111]

syn Nadirörnek ;
bendeki kodda kalem verisinin a14 hücresinden başlaması şart geriside borderler içinde olmak zorunda

 

[nadirornek]

Ömer bey sıkıntımız veriler arasındaki satır sayıları veri 2 adet veya dafazla olabiliyor en fazla veri 15 adet bir grupta olabiliyor.Verileri silip diğer veri aldığımda veriler arasında satır sayıları değişiyor ve bu değişmede bulunmuyor.

 

[Ömer]

Kodları #1 numaralı mesajda eklediğiniz dosyaya göre hazırladığımı belirtmiştim. Bu dosya üzerinde deneyip değerlendirmenizi rica ederim.

 

[nadirornek]

Ömer bey teşekkürler sonunda başardık tebrikler.Her türlü veriyi karşılaştırıyor.Azim her zaman zaferi getirir herkese teşekkürler.