Birleştirilmiş Hücreli Sayfalarda İstenen Verileri Süzmek

[ozgurruya]

İsimlere göre alt raporlar almam gerekiyor. Mesela "ööö" adını taşıyan ürünün bilgilerinin ayrı bir sayfada ya da aynı sayfa içersinde süzülmüş haline görmek istiyorum. "Filtre" uygulamayı denedm lakin tablodaki bazı hücreleri "Hücre Birleştir" özelliği ile birleştirdiğim için birleştirilmiş hücrelerdeki bazı bilgileri göstermiyor. Ayrıca aynı sebepten ötürü alt toplam da aldıramıyorum. Bendeki esas liste çok uzun olduğu için bir isme ait bilgileri tek tek kopyalayıp ayrı bir yere yapıştrıma işlemim saatlerimi alacaktır. İlginiz için teşekkür ederim.

Not: Excel Dosyası ekte verilmiştir.

 

[muygun]

Slm.
Tablonuzda f sütunundan isim süzmesini yapın.
İyi çalışmalar.

 

[ozgurruya]

Sayın muygun ilginiz için çok teşekkür ederim. İsim süzmesini başka bir excelde uygulamaya çalışıyorum ama doğru bir şekilde süzme yapamadım. Çünkü birleştirdiğim üç hücreyi yine birleşik olarak gördü. Bu yüzden isim süzmesini nasıl yaptığınızı anlatabilir misiniz?

 

[Ferhat Pazarçevirdi]

Sayfa1'e benzer ikinci bir sayfa (Sayfa2) yaratıldıktan sonra;

Aşağıdaki kodlar, bu sayfanın modulüne yazıldı. İnceleyiniz.

Option Explicit
Dim colL As Collection
Private Sub Worksheet_Activate()
    Dim col As Collection
    Dim i As Integer
    Dim itm As Variant
    
    On Error GoTo hata1
    
    Application.EnableEvents = False
    Columns("AA:AC").ClearContents
    
    
    For i = 0 To 2
        Set col = Col_Olustur(i + 2)
        
        For Each itm In col
            Cells(Cells(65536, 25 + i + 2).End(xlUp).Row + 1, 25 + i + 2) = itm
        Next
    
    Next i
    
hata1:
    
    If Err > 0 Then
        MsgBox "Aşağıdaki hata ile karşılaşıldı" & vbLf & vbLf & _
                Err.Number & " " & Err.Description, vbCritical, "İşlem Gerçekleştirilemiyor"
        Range("A6:E1000").ClearContents
    End If
    Application.EnableEvents = True
End Sub
 
'----------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    Dim rg As Range
    Dim rg1 As Range
    Dim hcr As Range
    Dim sonstr As Integer
    
    On Error GoTo hata
    
    If Not Intersect(Target, Range("B2:D3")) Is Nothing Then
        
        Application.EnableEvents = False
        
        Range("A6:E1000").ClearContents
        
        With Sheets("Sayfa1")
            For i = 2 To .Cells(65536, 4).End(xlUp).Row
                
                If IsEmpty(Cells(2, 4)) Then
                
                    If Not IsEmpty(.Cells(i, 2)) Then
                        If IsEmpty(Cells(2, 2)) Or CDate(.Cells(i, 2)) >= CDate(Cells(2, 2)) Then
                            If IsEmpty(Cells(3, 2)) Or CDate(.Cells(i, 2)) <= CDate(Cells(3, 2)) Then
                                
                                If .Cells(i, 2).MergeCells Then
                                    Set rg = .Cells(i, 2).MergeArea
                                Else
                                    Set rg = .Cells(i, 2)
                                End If
                            
                                If IsEmpty(Cells(2, 3)) Or Cells(2, 3) = .Cells(i, 3) Then
                                    If IsEmpty(Cells(2, 4)) Or Cells(2, 4) = .Cells(i, 4) Then
                                        sonstr = Cells(65536, 2).End(xlUp).Row + 1
                                                                                    
                                        Set rg = .Range(.Cells(rg.Row, rg.Column + 2), .Cells(rg.Row + rg.Cells.Count - 1, rg.Column + 2))
                                        
                                        For Each hcr In rg.Cells
                                            Cells(sonstr, 2) = .Cells(i, 2)
                                            Cells(sonstr, 3) = .Cells(i, 3)
                                            Cells(sonstr, 4) = hcr
                                            Cells(sonstr, 5) = hcr.Offset(0, 1)
                                            sonstr = sonstr + 1
                                        Next
                                        
                                    End If
                                End If
                            End If
                        End If
                    End If
                
                Else
                    
                    sonstr = Cells(65536, 2).End(xlUp).Row + 1
                    
                    If .Cells(i, 4) = Cells(2, 4) Then
                        
                        If .Cells(i, 4).Offset(0, -1).MergeCells Then
                            Set rg = .Cells(i, 4).Offset(0, -1).MergeArea
                            If .Cells(rg.Row, 3) = Cells(2, 3) Or IsEmpty(Cells(2, 3)) Then
                                Set rg = rg
                            Else
                                Set rg = Nothing
                            End If
                        Else
                            If .Cells(i, 3) = Cells(2, 3) Or IsEmpty(Cells(2, 3)) Then
                                Set rg = .Cells(i, 4).Offset(0, -1)
                            Else
                                Set rg = Nothing
                            End If
                        End If
                                
                        If .Cells(i, 4).Offset(0, -2).MergeCells Then
                            Set rg1 = .Cells(i, 4).Offset(0, -2).MergeArea
                            If .Cells(rg1.Row, 2) >= Cells(2, 2) Or IsEmpty(Cells(2, 2)) And _
                                .Cells(rg1.Row, 2) <= Cells(3, 2) Or IsEmpty(Cells(3, 2)) Then
                                Set rg1 = rg1
                            Else
                                Set rg1 = Nothing
                            End If
                        Else
                            If (.Cells(i, 2) >= Cells(2, 2) Or IsEmpty(Cells(2, 2))) And _
                                (.Cells(i, 2) <= Cells(3, 2) Or IsEmpty(Cells(3, 2))) Then
                                Set rg1 = .Cells(i, 2)
                            Else
                                Set rg1 = Nothing
                            End If
                        End If
                            
                        If Not rg Is Nothing And Not rg1 Is Nothing Then
                            Cells(sonstr, 2) = .Cells(rg1.Row, 2)
                            Cells(sonstr, 3) = .Cells(rg.Row, 3)
                            Cells(sonstr, 4) = .Cells(i, 4)
                            Cells(sonstr, 5) = .Cells(i, 5)
                        End If
                    
                    End If
                End If
            Next i
        End With
            
    End If
hata:
    Set rg = Nothing
    Set rg1 = Nothing
    If Err > 0 Then
        MsgBox "Aşağıdaki hata ile karşılaşıldı" & vbLf & vbLf & _
                Err.Number & " " & Err.Description, vbCritical, "İşlem Gerçekleştirilemiyor"
        Range("A6:E1000").ClearContents
    End If
    Application.EnableEvents = True
End Sub
 
'---------------------------------------------------
Private Function Col_Olustur(stn As Integer) As Collection
    Dim i As Integer
    Dim y As Integer
    Dim itm As Variant
        
    Set colL = New Collection
    
    On Error Resume Next
    
    With Sheets("Sayfa1")
        For i = 2 To .Cells(65536, 4).End(xlUp).Row
            colL.Add CStr(.Cells(i, stn)), CStr(.Cells(i, stn))
        Next i
    End With
    
    On Error GoTo 0
    
    Set Col_Olustur = colL
End Function

 

[ozgurruya]

Sayın Muygun'un çözümünü uygulayabildim sağlıklı bir şekilde teşekkür ederim sayın mugun.

Ayrıca sayın Ferhat Pazlarçevirdi bey size de teşekkür ederim. Visaul Basic kodu yazarak çözüm getirmeniz epey katkıda bulundu bana.