Çözüldü Birçok değişken kritere göre filtreleme yapmak ve yeni sayfaya kopyalamak

[KoNFiCuS]

Merhaba Üstadlar,

Ekte örneği bulunan dosyada yapmak istediğim A ve B sütunlarındaki verilere göre filtreleme yapıp yeni sayfa oluşturmak, hatta yeni sayfa ismi filtre ismi gibi olursa süper olur.

Mesela A daki İzmir ile B deki Antalya yı filtereleyip, yeni sayfaya İzmir-Antalya adı verip sadece onun bilgilerini kopyalaması ve bu şekilde diğerlerini filtreleyerek kopyalama yapması mümkün mü?

Valla sabahtan beri Array lar ile dictionary ile yapmaya çalıştım, dic kaydetsem bile autofilter da kriter olarak getirmeyi beceremedim, Array tam olarak uymadı.

Elinde benzer bir proje yapılmış olan, yada bana bu sorunun çözümü konusunda yardımcı olabilecek kimse var mı?

Çok teşekkürler.

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu bir module kopyalayıp çalıştırınız.

Sub Test()
    Dim Syf As Worksheet
    Set Syf = ActiveSheet
    Range("A1").AutoFilter
    ActiveSheet.Range("A:D").AutoFilter Field:=1, Criteria1:="İzmir"
    ActiveSheet.Range("A:D").AutoFilter Field:=2, Criteria1:="Antalya"
    Range("A1", Range("D1").End(xlDown)).Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "İzmir-Antalya"
    ActiveSheet.Paste
    Syf.Activate
    Range("A1").AutoFilter
End Sub

 

[KoNFiCuS]

Merhaba.

Aşağıdaki kodu bir module kopyalayıp çalıştırınız.

Sub Test()
    Dim Syf As Worksheet
    Set Syf = ActiveSheet
    Range("A1").AutoFilter
    ActiveSheet.Range("A:D").AutoFilter Field:=1, Criteria1:="İzmir"
    ActiveSheet.Range("A:D").AutoFilter Field:=2, Criteria1:="Antalya"
    Range("A1", Range("D1").End(xlDown)).Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "İzmir-Antalya"
    ActiveSheet.Paste
    Syf.Activate
    Range("A1").AutoFilter
End Sub

Merhaba, bu sabit bir kriter ile kopyalama ve sayfa isimlendirme yapıyor, yapmak istediğim data içerisindeki her bir şehir için ayrı ayrı filtreleme ve kopyalama sonra sayfa adı yapan bir kod.

Teşekkürler.

 

[Necdet]

Merhaba,
ChatGPT nin kodları başlangıç için işinize yarar mı?

Sub FiltreDegerleriniBul()

    Dim ws As Worksheet
    Dim filtreAlanı As Range
    Dim filtreA As String, filtreB As String
   
    ' Aktif sayfayı belirle
    Set ws = ActiveSheet
   
    ' Otomatik filtre aktif değilse hata mesajı göster
    If ws.AutoFilterMode = False Then
        MsgBox "Herhangi bir filtre uygulanmamış!", vbExclamation
        Exit Sub
    End If
   
    ' Filtre alanını belirle (örnek: A ve B sütunları)
    Set filtreAlanı = ws.AutoFilter.Range
   
    ' A sütunundaki filtreyi kontrol et
    If ws.AutoFilter.Filters(1).On Then
        filtreA = ws.AutoFilter.Filters(1).Criteria1
    Else
        filtreA = "A sütununda filtre yok"
    End If
   
    ' B sütunundaki filtreyi kontrol et
    If ws.AutoFilter.Filters(2).On Then
        filtreB = ws.AutoFilter.Filters(2).Criteria1
    Else
        filtreB = "B sütununda filtre yok"
    End If
   
    ' Filtre değerlerini göster
    MsgBox "A Sütunu Filtre: " & filtreA & vbNewLine & _
           "B Sütunu Filtre: " & filtreB, vbInformation
End Sub

Açıklamalar

1. AutoFilter.Filters(1)veAutoFilter.Filters(2) :
   • Bu özellikler, A sütununun ve B sütununun birleşimini temsil eder. Criteria1özelliği, uygulanan filtre değeri döner.
2. OnÖzelliği :
   • İlgili sütun için bir filtre olup olmadığını kontrol eder. Filtre yoksa boş bırakılırsa.
3. Mesaj Kutusu :
   • Uygulanan filtrelerin değerleri bir mesaj azaltılarak görüntülenir.

Noterler

• Birden fazla filtre değeri kullanılmışsa (örneğin, birden fazla koşulda) Criteria1ve Criteria2özelliklerine bu şekilde erişebilirsiniz.
• Filtrelenen alanın hangi sütunlar üzerinde açıldığı özelliği mevcuttur AutoFilter.Filters.Count.

Bu kod, otomatik filtre özelliği aktif olan bir Excel sayfasında çalışır ve A ile B sütunlarına uygulanmış filtrelerin ayrıntılarının çalışmasını sağlar.

 

[Muzaffer Ali]

Merhaba, bu sabit bir kriter ile kopyalama ve sayfa isimlendirme yapıyor, yapmak istediğim data içerisindeki her bir şehir için ayrı ayrı filtreleme ve kopyalama sonra sayfa adı yapan bir kod.

Teşekkürler.

Aşağıdaki kodu deneyin.

Sub Test()
    Dim Syf As Worksheet
    Dim SyfFlt As Worksheet
    Dim Bak As Integer
    
    Application.ScreenUpdating = False
    Set Syf = ActiveSheet
    Syf.Range("A:B").Copy
    Set SyfFlt = Worksheets.Add(After:=ActiveSheet)
    SyfFlt.Range("A1").PasteSpecial
    SyfFlt.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    
    For Bak = 2 To SyfFlt.Cells(Rows.Count, "A").End(xlUp).Row
        Syf.Activate
        Syf.Range("A:D").AutoFilter Field:=1, Criteria1:=SyfFlt.Cells(Bak, "A").Text
        Syf.Range("A:D").AutoFilter Field:=2, Criteria1:=SyfFlt.Cells(Bak, "B").Text
        Syf.Range("A1", Range("D1").End(xlDown)).Copy
        Sheets.Add After:=ActiveSheet
        ActiveSheet.Name = SyfFlt.Cells(Bak, "A").Text & " - " & SyfFlt.Cells(Bak, "B").Text
        ActiveSheet.Paste
    Next
    Syf.Activate
    Range("A1").AutoFilter
    Application.DisplayAlerts = False
    SyfFlt.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı."
End Sub

 

[KoNFiCuS]

Aşağıdaki kodu deneyin.

Sub Test()
    Dim Syf As Worksheet
    Dim SyfFlt As Worksheet
    Dim Bak As Integer
   
    Application.ScreenUpdating = False
    Set Syf = ActiveSheet
    Syf.Range("A:B").Copy
    Set SyfFlt = Worksheets.Add(After:=ActiveSheet)
    SyfFlt.Range("A1").PasteSpecial
    SyfFlt.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
   
    For Bak = 2 To SyfFlt.Cells(Rows.Count, "A").End(xlUp).Row
        Syf.Activate
        Syf.Range("A:D").AutoFilter Field:=1, Criteria1:=SyfFlt.Cells(Bak, "A").Text
        Syf.Range("A:D").AutoFilter Field:=2, Criteria1:=SyfFlt.Cells(Bak, "B").Text
        Syf.Range("A1", Range("D1").End(xlDown)).Copy
        Sheets.Add After:=ActiveSheet
        ActiveSheet.Name = SyfFlt.Cells(Bak, "A").Text & " - " & SyfFlt.Cells(Bak, "B").Text
        ActiveSheet.Paste
    Next
    Syf.Activate
    Range("A1").AutoFilter
    Application.DisplayAlerts = False
    SyfFlt.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı."
End Sub

Çok teşekkür ederim, çok temiz sade ve tam istediğim kod olmuş...

 

[KoNFiCuS]

ayrıca uzun uğraşlar sonucu Dictionary kullanarak alltaki kodu başardım bende, biraz karmaşık kod ama aynı işlemi yapıyor.

alternatif olarak kalsın.

Option Explicit
Sub DesArrCities()

If Cells(1, 2) = "" Then

    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    
End If

Dim lastRow As Long, LastCol As Long

If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
  ActiveSheet.ShowAllData
End If

lastRow = Cells(Rows.Count, 1).End(xlUp).row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Cells.Select
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit

    Dim dictCity As Object, arrCity As Object, key, key2 As Variant, x, y, i As Long, ws As Worksheet
    'Dim lastRow As Long
    
    Set ws = ActiveSheet
    Set dictCity = CreateObject("scripting.dictionary")
    Set arrCity = CreateObject("scripting.dictionary")
    x = Application.Transpose(Range("A2", Cells(Rows.Count, "A").End(xlUp)))
    
    For i = 1 To UBound(x, 1)   '<< fill the dictionary with unique values
        dictCity(x(i)) = 1
    Next
    
    y = Application.Transpose(Range("B2", Cells(Rows.Count, "B").End(xlUp)))
    
    Set arrCity = CreateObject("scripting.dictionary")
    y = Application.Transpose(Range("B2", Cells(Rows.Count, "B").End(xlUp)))
    
    For i = 1 To UBound(y, 1)   '<< fill the dictionary with unique values
        arrCity(y(i)) = 1
    Next

    
    For Each key In dictCity.keys   '<< begin looping through the keys
        With ws.Cells(1, 1).CurrentRegion
            .AutoFilter 1, key, 7
            
            
            For Each key2 In arrCity.keys
            With ws.Cells(1, 2).CurrentRegion
            .AutoFilter 2, key2, 7
 
        lastRow = Cells(Rows.Count, "A").End(xlUp).row
        
        If lastRow > 1 Then

            .Copy
            Sheets.Add After:=ActiveSheet
            ActiveSheet.name = key & "-" & key2
                
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
          
           Application.CutCopyMode = False
          
           End If
          
            
          ws.Select
           .AutoFilter 2
        End With
        
      
      Next key2
      End With
    Next key
    
ActiveSheet.ShowAllData
    
End Sub

 

[Necdet]

Merhaba,
Bu da başka bir seçenek olsun. Biraz Filtre, biraz dictionary
Kod sayfa yoksa açar, varsa içini temizler, sonra aktarır. Dolayısayla defalarca çalıştırılsa bile hata alınmaz.

Referanslardan Microsoft Scripting Runtime seçili olmalı.

Sub Deneme()

Dim arr As Variant
Dim dic As New Scripting.Dictionary
Dim i   As Long
Dim deg As Variant
Dim rng As Range
Dim sh  As Worksheet

Application.ScreenUpdating = False

Set sh = ActiveSheet

arr = sh.Range("A1").CurrentRegion.Value
Set rng = sh.Range("A1").CurrentRegion

For i = 2 To UBound(arr, 1)
    deg = arr(i, 1) & "-" & arr(i, 2)
    If Not dic.Exists(deg) Then dic.Add deg, deg
Next i

If ActiveSheet.AutoFilterMode = False Then ActiveSheet.Range("A1").AutoFilter

For i = 0 To dic.Count - 1
    deg = Split(dic.Items(i), "-")
    rng.AutoFilter Field:=1, Criteria1:=deg(0)
    rng.AutoFilter Field:=2, Criteria1:=deg(1)
    If SayfaVar(CStr(dic.Items(i))) = False Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = dic.Items(i)
    Else
        Sheets(dic.Items(i)).Cells.ClearContents
    End If
    rng(1, 1).CurrentRegion.Copy Sheets(dic.Items(i)).Range("A1")
    Cells.Columns.AutoFit
Next i

sh.Select
Selection.AutoFilter

Application.ScreenUpdating = True

End Sub

Function SayfaVar(syfAdi As String) As Boolean
    On Error Resume Next
    SayfaVar = CBool(Len(Worksheets(syfAdi).Name) > 0)
End Function