Makro ile sıralama

[şehiriçi]

Merhaba Değerli Excel Dostları,
Arkadaşlar ekte ki dosyamın sehirici sayfasında gerekli izahı yaptım.
Burada da kısaca özetlersem; tablomun D sütununda 24 adet blok halinde zemin rengi renklendirilmiş veriler mevcut
Her veri ortalama 9-10 satırdan ibarettir.
Amacım B sütununda karşılığı mevcut olan bu blokların F_G_H sütunlarına makrolu bir şekilde kayıt olması, benim kapasitemi aşan bu blokların siz Excel ustaları için zor olmayacağına inanıyor ve sabırsızlıkla cevabınızı bekliyorum, teşekkürler.

 

[şehiriçi]

arkadaşlar bu sorunun cevap bulması benim için çok önemli o yüzden güncel tutuyorum

 

[kulomer46]

Merhaba

Talebinizi karşılayan dosya Ek' tedir.

Selamlar...

 

[şehiriçi]

sayın kulomer46 ilginize çok teşekkürler , ancak benim istediğim bu değil
istediğim D sütununda zemin rengi renklendirilmiş mesela D3D12 bloğu (hep sarı renk) B sütununda aranacak ve
bulunan blok un olduğu satıra ait olan A B C sütunlarındaki veriler FGH sütunlarına yazılacak .
ben örnek olması açısından D3D12 bloğundan 3 adet bulup yazdım bir adet de D3D21 bloğundan bulup yazdım
E sütununa da hangi blok a ait olduğunu yazdım..umarım karıştırmadan anlatabilmişimdir
revize edilen dosyanız ekte

 

[kulomer46]

Merhaba

Şu an dışardan yeni geldim. Talebinizi okudum ama çözemedim.
Sakin kafayla daha sonra tekrar inceleyeceğim İnşallah.

Selamlar...

 

[şehiriçi]

güncel

 

[şehiriçi]

güncel

 

[kulomer46]

Değerli Arkadaşım Tekrar Merhaba

Talebinizi tekrar tekrar inceledim fakat anlayamadım.
Şu an için çözüm üretemiyorum.

Selamlar...

 

[Ömer]

Merhaba,

Detaylı deneme yapmadım.

Sub blok_bul()

    Dim dizi(), sat As Long, a As Long, b As Long, deg As String, s As Integer, i As Long, hcr As Range
    Dim c As Range, Adr As String, t As Integer, d1 As String, d2 As String, j As Integer
   
    Application.ScreenUpdating = False
    Range("F3:H" & Rows.Count).Clear
   
    sat = 3
    a = 3
    For i = 3 To Cells(Rows.Count, "D").End(xlUp).Row
        If Cells(i, "D").Interior.ColorIndex <> Cells(i + 1, "D").Interior.ColorIndex Then
            b = i
            ReDim Preserve dizi(s)
            dizi(s) = "D" & a & ":D" & b
            s = s + 1
            a = i + 1
        End If
    Next i

    For j = 0 To UBound(dizi)
        deg = Range(Split(dizi(j), ":")(0))
        s = Range(dizi(j)).Count
        Set c = [B:B].Find(deg, , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                t = 0
                For Each hcr In Range(dizi(j))
                    d1 = UCase(Replace(Replace(hcr, "ı", "I"), "i", "İ"))
                    d2 = UCase(Replace(Replace(Cells(c.Row + t, "B"), "ı", "I"), "i", "İ"))
                    If d1 = d2 Then
                        t = t + 1
                    Else
                        Exit For
                    End If
                Next
               
                If t = s Then
                    Cells(c.Row, "A").Resize(s, 3).Copy Cells(sat, "F")
                    sat = Cells(Rows.Count, "F").End(xlUp).Row + 1
                End If
                Set c = [B:B].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next j
   
    MsgBox "Aktarım Bitti."
   
End Sub

 

[Korhan Ayhan]

Bende hazırlamıştım. Alternatif olsun.

Doğruluklarını kontrol etmeniz için I ve J sütununa blok numaralarını ve satır numaralarını ekledim. Sonuçlar doğru ise bu alanları silebiliriz.

Option Explicit

Sub Bloklari_Ara_Uyanlari_Listele()
    Dim Zaman As Double, Blok_Listesi As Object, Blok_Sayilari As Object, X As Long, Bloklar As Range
    Dim Y As Long, Blok_Say As Long, Son As Long, Veri As Variant, Sayi As Variant, Say As Long
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set Blok_Listesi = CreateObject("Scripting.Dictionary")
    Set Blok_Sayilari = CreateObject("System.Collections.ArrayList")
    
    Range("F3:J" & Rows.Count).ClearContents
    
    For X = 3 To Cells(Rows.Count, "D").End(3).Row
        If Cells(X, "D") <> "" Then
            If Bloklar Is Nothing Then
                Set Bloklar = Cells(X, "D")
            Else
                Set Bloklar = Union(Bloklar, Cells(X, "D"))
            End If
            
            For Y = X + 1 To Cells(Rows.Count, "D").End(3).Row + 1
                If Cells(X, "D").Interior.Color = Cells(Y, "D").Interior.Color Then
                    If Bloklar Is Nothing Then
                        Set Bloklar = Cells(Y, "D")
                    Else
                        Set Bloklar = Union(Bloklar, Cells(Y, "D"))
                    End If
                Else
                    If Not Blok_Sayilari.Contains(Bloklar.Cells.Count) Then Blok_Sayilari.Add Bloklar.Cells.Count
                    Blok_Say = Blok_Say + 1
                    Blok_Listesi.Add WorksheetFunction.Trim(UCase(Replace(Replace(Join(Application.Transpose(Bloklar.Value), ","), "ı", "I"), "i", "İ"))), Blok_Say
                    Set Bloklar = Nothing
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next

    Son = Cells(Rows.Count, "A").End(3).Row
    If Son < 4 Then Son = 4

    Veri = Range("A3:C" & Son).Value

    Blok_Sayilari.Sort
    Blok_Sayilari.Reverse

    ReDim Yer(1 To 1)
    ReDim Liste(1 To UBound(Veri, 1), 1 To 5)

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Each Sayi In Blok_Sayilari
            For Y = 1 To Sayi
                If (X + Y - 1) > UBound(Veri, 1) Then Exit For
                ReDim Preserve Yer(1 To Y)
                Yer(Y) = Veri(X + Y - 1, 2)
            Next
            
            If Blok_Listesi.Exists(WorksheetFunction.Trim(UCase(Replace(Replace(Join(Yer, ","), "ı", "I"), "i", "İ")))) Then
                For Y = 1 To Sayi
                    If (X + Y - 1) > UBound(Veri, 1) Then Exit For
                    Say = Say + 1
                    Liste(Say, 1) = Veri(X + Y - 1, 1)
                    Liste(Say, 2) = Veri(X + Y - 1, 2)
                    Liste(Say, 3) = Veri(X + Y - 1, 3)
                    Liste(Say, 4) = Blok_Listesi.Item(WorksheetFunction.Trim(UCase(Replace(Replace(Join(Yer, ","), "ı", "I"), "i", "İ"))))
                    Liste(Say, 5) = X + Y + 1
                Next
            End If
        Next
    Next

    If Say > 0 Then
        Range("F3").Resize(Say, 5) = Liste
        Range("H3").Resize(Say).NumberFormat = "hh:mm:ss"
        
        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
        End With
        
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
        End With
        
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
    
    Set Blok_Listesi = Nothing
    Set Blok_Sayilari = Nothing
End Sub

 

[şehiriçi]

Ömer bey ve Korhan bey yazdığınız kodları gördüm ve çok sevindim . Her ikinizden de Allah razı olsun . öncelikle her ikinizin kodlarını projemde deneyip neticeyi sizinle paylaşacağım , teşekkürler
Sağlıkla kalın.

 

[şehiriçi]

Merhaba Korhan bey , sizin verdiğiniz kod da blokların numaralandırılması daha çok işime yarayacağı için Ömer beyin kod yerine sizin kodu tercih ettim ve 1 nisan 2021 tarihli yeni verileri girdim .
1 ) Makro lar da çok yeni olduğum için yazdığınız kodun mantığını anlamam uzun zaman alacak öğrenmeye çalışıyorum.örnek create object,reserve,redim,redim preserve,exists,trim,resize,contains vs bunları nedir bilmiyor ve araştırıyorum ama zaman alacak. oysa ben bir an önce sonuca gitmek için bir nevi sizin yazdığınız kodu ezbere kullanacağım uzatmayayım ,kodla ilgili 2 sorum olacak
2 ) g 783_g 791 ve g 792_g 800 . satırlar I sütununda 14 . blok olarak tespit ediliyor . kontrol ettiğimde g sütunundaki 783_791 ve 792_800 satırlar 13 blokla örtüşüyor . kod kapasitem yetersiz olduğu için düzeltemedim . rica etsem onu düzeltir misiniz
3 ) bloklar 24 adet yapmıştım ama en fazla 72 olabiliyor . o yüzden blok adedini 72 olacak şekilde revize edebilir misiniz
son olarak üzerinde çalıştığım taslak haldeki excel çalışma dosyamı gönderiyorum .ulaşmaya çalıştığım asgari sonuç s3 u10 hücrelerindedir ,
biliyorum sizi de yoruyorum , o kadar emek verdiniz , teşekkür ediyorum . yukarı da ki düzeltmeyi yapıp bana da anlamadığım (create object,resize vs) gibi yabancı olduğum kelimeleri nasıl öğreneceğim konusunda önereceğiniz bir şey olursa duymak isterim , çok uzattım bizim için , harcadığınız zaman a emeğinize ne desek eksik kalır . hakkınızı helal edin sağolun varolun , sağlıkla kalın . (ben yukarıda bilmediğim kelime leri öğrenmek için gayret gösteriyor olacağım )
dosyam ekte

 

[Korhan Ayhan]

Bu makro kodlarında kullandığım metotlar yoğun veri yığınlarında hızlı sonuç verecek kodlardır. Bunlar yeni başlayanlar için biraz ağır gelebilir.

Eğer hesaplama yöntemini ELLE şeklinde ayarlayıp kodu denerseniz ~1 saniye civarında işlem sürmektedir. Diğer yöntemlerde bu süre büyük ihtimalle artacaktır. Kodda yaptığım revize ile normal hesaplama ayarında ise bende ~5 saniye civarında sonuç üretiyor.

Blok sayısında bir sınırlama koymamıştım. Fakat kodu tekrar incelediğimde bir yerde mantıksal bir eksiklikten dolayı en sondaki bloğu işleme dahil etmediğini tespit ettim. Bunu eksikliği düzelttim. Güncel kod #10 nolu mesajımdadır.

2. tespitiniz yaptığım güncelleme ile düzeldi. Fakat ilgili satırlarda ki bloklar için 15. blok numarasını sonuç olarak verdi. Siz doğruluğunu kontrol edersiniz.

Ek olarak makroları öğrenmek için bol bol araştırma ve deneme yapmanızı tavsiye ederim. Yeni başlayanlar için MAKRO KAYDET yöntemini kullanmalarını öneriyorum. Nette arama yaparsanız gerekli bilgilere ulaşabilirsiniz.

Kolaylıklar dilerim.

 

[şehiriçi]

Tekrar Merhaba Korhan Bey ,
1. yeni bir blok ilave ettim ama o bloğu görmedi
2. verdiğiniz kod lar blokları zemin rengine göremi tanıyor .rengi değiştirince de hata veriyor . ilave ettiğim blok ve son hali dosyanın ekte ,
saygılar .

 

[Korhan Ayhan]

Ben kodu çalıştırdığımda 25 adet blok oluştuğunu görüyorum.

Evet verdiğiniz renklere göre blokları ayırıyor. Şu haliyle başka bir seçenekte yok zaten.

#10 nolu mesajımı tekrar revize ettim. Deneyiniz.

 

[şehiriçi]

Korhan bey özür dilerim sizi de yoruyorum ama renklere göre kod lama yapmak ilerde sıkıntı verir bana
o yüzden ben yeni dosyada A sütununa blokları oluşturdum.
eğer D sütununda ki verilerden , oluşturulan A sütununda (ilerde blok ilave edeceğiz ben 72 adet yaptım buda bizim sınır olur) ki bloklardan varsa C,D,E sütununu bu sefer M,N,O sütununa kaydedersek sıkıntım çözülür zannımca

 

[Korhan Ayhan]

Bu durumda şöyle yapmak daha mantıklı olur.

A sütununa blok numaralarını yazın.
B sütununa yer adlarını yazın.
20'şer satırlık bloklar oluşturun.

Buna göre dosya yükleyin kodu revize edelim.

 

[şehiriçi]

Korhan by gönderdiğim son dosyaya baktınız mı orada A sütununa blokları 20 şerli satır şeklinde yazmıştım.
ama sizin istediğiniz 1111111 , 222222 şeklinde mi ben yeni dosya oluşturuyorum umarım istediğinizi yaparım.

 

[Korhan Ayhan]

Blokların birbirine benzeme durumu var mı? Sanki #16 nolu mesajınızda ki dosyada bu durum oluşmuş. Kontrol eder misiniz?

Blok2 ve Blok3 aynı yerleri içeriyor. Bu karışıklık yaratır.

 

[şehiriçi]

Doğrusunuz Korhan bey acele ederek aynı blokları yazmışım ; blok2 ve blok 3 e ,
bloklar birbirinin aynı olamaz.