İstenilen sütundaki filtre sonuçlarının herbirini ayrı sayfalara kopyalama

meleklerim · 8 Nisan 2022

Merhabalar, yine ben

ekte gönderdiğim excel belgesi, 7 sütun 28 satırdan oluşan bir tablonun yer aldığı Tablo adında bir sayfa ve Bölüm adında başka sayfası olan iki sayfalık bir belgeden oluşuyor. Tabloda Bölüm alanının bulunduğu sütundaki her bölümün bölüm sayfasına aralarına 50 satır konularak başlıklarıyla beraber ayrı ayrı kopyalanmasını sağlayacak bir makro istiyorum. Örnek dosyada manuel yaptığım için ne istediğim daha iyi anlaşılacaktır.
Örnek olarak tabloda imalat bölümünde çalışanları bölüm sayfasında A2 den başlayarak kopyalamasını yönetim bölümünde çalışanları A52 başlayarak kopyalamasını, tanıtım bölümünde çalışanları A102 den başlayarak vs vs kopyalamasını istiyorum.
Yani her bölümü diğer bölümle arasına 50 satır koyarak kopyalamalı.
Bir bölümde çalışan sayısı 50 den fazla olamayacağı için üstüste binmez.
Bölüm sayısı da yine 50 den fazla olmaz.
Tablonun satır ve sütun sayıları değişebilir.
Gönül ister ki ilerde hangi sütunun hangi sayfaya kopyalanacağını bir hücreye bağlı olarak değiştirebileyim.
Yardımcı olacak arkadaşlara şimdiden teşekkür ve en derin saygılarımla

Korhan Ayhan · 10 Nisan 2022

Deneyiniz.

C++:

Option Explicit

Sub Bolumleri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, X As Long, Son As Long, Say As Long
    Dim Y As Byte, WF As WorksheetFunction, Zaman As Double
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Set S1 = Sheets("Tablo")
    Set S2 = Sheets("Bölüm")
    Set WF = WorksheetFunction
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    S2.Cells.Clear
    
    Son = WF.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)
    
    Veri = S1.Range("A2:G" & Son).Value
    
    ReDim Liste(1 To S2.Rows.Count, 1 To 7)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" And Veri(X, 1) <> "SİCİL NO" Then
            If Not Dizi.Exists(Veri(X, 2)) Then
                Say = IIf(Say = 0, 1, Say + 51)
                Dizi.Add Veri(X, 2), Array(Say, 1)
                For Y = 1 To 7
                    Liste(Say, Y) = Veri(1, Y)
                    Liste(Say + 1, Y) = Veri(X, Y)
                Next
                Dizi.Item(Veri(X, 2)) = Array(Say + 1, 1)
            Else
                For Y = 1 To 7
                    Liste(Dizi.Item(Veri(X, 2))(0) + 1, Y) = Veri(X, Y)
                Next
                Dizi.Item(Veri(X, 2)) = Array(Dizi.Item(Veri(X, 2))(0) + 1, 1)
            End If
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A2").Resize(Say, 7) = Liste
        Erase Liste
        Dizi.RemoveAll
        S2.Range("A:G").AutoFilter 1, "SİCİL NO"
        S2.Range("A2:G" & S2.Cells(S2.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Font.Bold = True
        S2.Range("A2:G" & S2.Cells(S2.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Interior.Color = 14277081
        S2.ShowAllData
        S2.Columns.AutoFit
        Application.ScreenUpdating = True
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.ScreenUpdating = True
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
    Set Dizi = Nothing
End Sub

irfem4 · 11 Nisan 2022

ekli dosyayı bi inceleyin. inşallah doğru anlamışımdır.

irfem4 · 11 Nisan 2022

bir önceki mesajı dikkate almayınız. tablo bölümüne veri girişi yapıldığında tablo sayfası p3

8 hücrelerindeki sıralamaya göre bölüm sayfasına otomatik sıralama yapacaktır.

Haluk · 11 Nisan 2022

"ADODB.Recordset" nesnesinin "Filter" özelliğini kullanarak bir alternatif;

C#:

Sub Test()
    ' Haluk 11/04/2022
    ' sa4truss@gmail.com
    '
    Dim RS As Object, i As Long, NoA As Long
    Dim Sh As Worksheet
    
    Const adWChar = 130
    Const adDouble = 5
        
    Set RS = CreateObject("ADODB.Recordset")
    RS.Fields.Append "Sicil", adDouble
    RS.Fields.Append "Bolum", adWChar, 10
    RS.Fields.Append "Ad", adWChar, 20
    RS.Fields.Append "Soyad", adWChar, 20
    RS.Fields.Append "Cinsiyet", adWChar, 5
    RS.Fields.Append "DoğumYılı", adDouble
    RS.Fields.Append "DoğumYeri", adWChar, 15
    RS.Open
    
    NoA = Sheets("Tablo").Range("A" & Rows.Count).End(xlUp).Row
    Set Sh = Sheets("Tablo")
    
    For i = 2 To NoA
        RS.AddNew
        RS.Fields("Sicil").Value = Sh.Range("A" & i)
        RS.Fields("Bolum").Value = Sh.Range("B" & i)
        RS.Fields("Ad").Value = Sh.Range("C" & i)
        RS.Fields("Soyad").Value = Sh.Range("D" & i)
        RS.Fields("Cinsiyet").Value = Sh.Range("E" & i)
        RS.Fields("DoğumYılı").Value = Sh.Range("F" & i)
        RS.Fields("DoğumYeri").Value = Sh.Range("G" & i)
    Next
    
    RS("Sicil").Properties("Optimize") = True
    
    RS.Update
    RS.Sort = "Sicil Asc"
    RS.MoveFirst
    
    RS.Filter = "Bolum = 'METAL'"
    Sheets("Bölüm").Range("A2").Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
    Sheets("Bölüm").Range("A3").Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
    
    RS.Filter = "Bolum = 'SATIŞ'"
    Sheets("Bölüm").Range("A52").Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
    Sheets("Bölüm").Range("A53").Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
    
    RS.Filter = "Bolum = 'ÜRETİM'"
    Sheets("Bölüm").Range("A102").Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
    Sheets("Bölüm").Range("A103").Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
        
    RS.Filter = "Bolum = 'İMALAT'"
    Sheets("Bölüm").Range("A152").Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
    Sheets("Bölüm").Range("A153").Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
    
    RS.Filter = "Bolum = 'TANITIM'"
    Sheets("Bölüm").Range("A202").Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
    Sheets("Bölüm").Range("A203").Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
    
    RS.Filter = "Bolum = 'YÖNETİM'"
    Sheets("Bölüm").Range("A252").Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
    Sheets("Bölüm").Range("A253").Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
    
    RS.Close
    Set RS = Nothing
End Sub

.

meleklerim · 11 Nisan 2022

@Korhan Ayhan Bey, mesajınızı biraz önce deneme fırsatı buldum. Çok hızlı çalışıyor. Ancak bir iki hususta düzeltme yapma imkanımız varsa çok sevinirim. Birincisi ilginç bir şekilde yeni eklenen bir bölümü listelemiyor. Bir diğer husus analize başlamadan önce bölüm sayfasını tümüyle siliyor. Bu birçok hatanın önlenmesi için gerekli bir durum kabul ediyorum ancak A1, A51, A101, ....(+50) satırlarına ben tablonun adını oluşturan formüller yerleştirmeyi düşünüyordum.
örnegin birinci sayfa için A1 hücresine "=birleştir(B2; "Bölümünde Çalışan Personeller Listesi") gibi."
ikinci sayfa için A51 "=birleştir(B52; "Bölümünde Çalışan Personeller Listesi") gibi." Bu durumda her liste aldıkça o formüller de silinecek. Bunun başka bir yolu olabilir mi? Silme için A1, A51, A101 ...+50
satırları istisna tutulabilir mi? O hücreleri koruma altına alsam makro düzgün çalışır mı? Ya da bu işlev makroya eklenebilir mi?
Yani aslında birinci sayfa için
A1 satırı tablo adı için (... Bölümü Çalışanları Listesi")
A2 satırı tablo başlıkları için (sicilno, bölümü, adısoyadı ...)
A3 ile A50 (ahmet, mehmet ....)

aynı şekilde
A51 satırı tablo adı için A52 satırı tablo başlıkları için a53 ile A100
A101 satırı tablo adı için A102 satırı tablo başlıkları için a103 ile A150
A151 satırı tablo adı için A152 satırı tablo başlıkları için a153 ile A200
......usw

Bu +50 sevdası nerden geliyor derseniz bir sayfa 50 satırdan oluşuyor. O bakımdan yoksa 50 den bağımsız her bölüm, bölüm sekmesinde bir sayfaya makro yolu ile yazılabilse ne ala.

Son olarak bölümleri listeledikten sonra bir sayfaya da sadece başlıkları kopyaladığı bir sayfa oluşturuyor.
Size kolaylıklar ve zihin açıklığı diliyorum. Hakkınız ödenmez

meleklerim · 11 Nisan 2022

@irfem4 Bey, konuma gösterdiğiniz ilgi alaka için teşekkür ederim. Formülleriniz gayet güzel çalışıyor, ancak ben bölüm sekmesinde formül olmasını istemiyorum. Bu zaten ağır çalışan belgemi daha da ağırlaştıracaktır. Her veri girişinde tüm formüllerin hesaplanması yeniden yapılıyor. Bu yüzden yararlanamam. Ama formüllerinizden yeni fikirler edindim. Aklınıza yüreğinize sağlık.

meleklerim · 11 Nisan 2022

@Haluk Bey, alternatif çözümünüzü henüz deneyemedim. Bu ADO olayına bir gün mutlaka girmem gerektiğinin farkındayım. @Erdem Akdemir beyin videolarını izleyerek az çok fikir edindim. Birçok üstün yanları var. İlk bakışta bile ne kadar sade olduğu anlaşılıyor. Ancak makronuzda filtrelenecek bölümlerin el ile yazılı olması benim kullanmama uygun değil. Çünkü ben sadece tablomu güncelleyeceğim ve orada bazı bölümler eklenecek belki bazı bölümler silinecek. Her seferinde makroya girip güncel bölümleri yazmak pratik değil gibi geliyor bana. O filtrlenen bölümleri kendi otomatik bulabilirse daha işlevsel olacağı kesin. Sizin de elinize emeğinize sağlık. Çok Çok teşekkürler

meleklerim · 11 Nisan 2022

6. mesajı düzeltemedim ve silemedim yeniden yazdım. 6. mesajı dikkate almayınız

@Korhan Ayhan Bey, mesajınızı biraz önce deneme fırsatı buldum. Çok hızlı çalışıyor. Ancak bir iki hususta düzeltme yapma imkanımız varsa çok sevinirim. Birincisi ilginç bir şekilde yeni eklenen bir bölümü listelemiyor. Bir diğer husus analize başlamadan önce bölüm sayfasını tümüyle siliyor. Bu birçok hatanın önlenmesi için gerekli bir durum kabul ediyorum ancak A1, A51, A101, ....(+50) satırlarına ben tablonun adını oluşturan formüller yerleştirmeyi düşünüyordum.
örnegin birinci sayfa için A1 hücresine "=birleştir(B2; "Bölümünde Çalışan Personeller Listesi") gibi."
ikinci sayfa için A51 "=birleştir(B52; "Bölümünde Çalışan Personeller Listesi") gibi." Bu durumda her liste aldıkça o formüller de silinecek. Bunun başka bir yolu olabilir mi? Silme için A1, A51, A101 ...+50 satırları istisna tutulabilir mi?
Ya da o satırları koruma altına alsam makronun çalışmasına bir zarar veriri mi?
Ya da (en güzeli) bu işlev makroya eklenebilir mi?
Yani aslında birinci sayfa için
A1 satırı tablo adı için (... Bölümü Çalışanları Listesi")
A2 satırı tablo başlıkları için (sicilno, bölümü, adısoyadı ...)
A3 ile A50 (ahmet, mehmet ....)

aynı şekilde
A51 satırı tablo adı için A52 satırı tablo başlıkları için a53 ile A100
A101 satırı tablo adı için A102 satırı tablo başlıkları için a103 ile A150
A151 satırı tablo adı için A152 satırı tablo başlıkları için a153 ile A200
......usw

Bu +50 sevdası nerden geliyor derseniz bir sayfa 50 satırdan oluşuyor. O bakımdan yoksa 50 den bağımsız her bölüm, bölüm sekmesinde bir sayfaya makro yolu ile yazılabilse ne ala.

Son olarak bölümleri listeledikten sonra bir sayfaya da sadece başlıkları kopyaladığı bir sayfa oluşturuyor.
Size kolaylıklar ve zihin açıklığı diliyorum. Hakkınız ödenmez

Haluk · 11 Nisan 2022

meleklerim' Alıntı:
.........Ancak makronuzda filtrelenecek bölümlerin el ile yazılı olması benim kullanmama uygun değil. Çünkü ben sadece tablomu güncelleyeceğim ve orada bazı bölümler eklenecek belki bazı bölümler silinecek. Her seferinde makroya girip güncel bölümleri yazmak pratik değil gibi geliyor bana. O filtrlenen bölümleri kendi otomatik bulabilirse daha işlevsel olacağı kesin.........

Departmanların Tablodan otomatik olarak ayıklanarak, diğer sayfada istenilen şekilde listeleme işleri için revize edilen kod aşağıdadır;

Örnek dosya da, bu mesaja eklenmiştir....

C#:

Sub Test2()
    ' Haluk 11/04/2022
    ' sa4truss@gmail.com
    '
    ' Departmanlari otomatik olarak ayiklamak icin.....
   
    Dim uniqueDepts As New Collection, RS As Object, i As Long, NoA As Long
    Dim Sh As Worksheet
   
    Const adWChar = 130
    Const adDouble = 5
   
    NoA = Sheets("Tablo").Range("A" & Rows.Count).End(xlUp).Row
   
    For i = 2 To NoA
        xMatch = Range("B" & i)
        On Error Resume Next
            uniqueDepts.Add xMatch, xMatch
        On Error GoTo 0
    Next

    Set RS = CreateObject("ADODB.Recordset")
    RS.Fields.Append "Sicil", adDouble
    RS.Fields.Append "Bolum", adWChar, 10
    RS.Fields.Append "Ad", adWChar, 20
    RS.Fields.Append "Soyad", adWChar, 20
    RS.Fields.Append "Cinsiyet", adWChar, 5
    RS.Fields.Append "DoğumYılı", adDouble
    RS.Fields.Append "DoğumYeri", adWChar, 15
    RS.Open
   
    NoA = Sheets("Tablo").Range("A" & Rows.Count).End(xlUp).Row
    Set Sh = Sheets("Tablo")
   
    For i = 2 To NoA
        RS.AddNew
        RS.Fields("Sicil").Value = Sh.Range("A" & i)
        RS.Fields("Bolum").Value = Sh.Range("B" & i)
        RS.Fields("Ad").Value = Sh.Range("C" & i)
        RS.Fields("Soyad").Value = Sh.Range("D" & i)
        RS.Fields("Cinsiyet").Value = Sh.Range("E" & i)
        RS.Fields("DoğumYılı").Value = Sh.Range("F" & i)
        RS.Fields("DoğumYeri").Value = Sh.Range("G" & i)
    Next
   
    RS("Sicil").Properties("Optimize") = True
   
    RS.Update
    RS.Sort = "Sicil Asc"
    RS.MoveFirst
   
    For i = 1 To uniqueDepts.Count
        RS.Filter = "Bolum = '" & uniqueDepts.Item(i) & "'"
        Sheets("Bölüm").Range("A" & 2 + iCount).Resize(, 7).Value = Split("Sicil No|Bölümü|Adı|Soyadı|Cinsiyeti|Doğum Yılı|Doğum Yeri", "|")
        Sheets("Bölüm").Range("A" & 3 + iCount).Resize(RS.RecordCount, 7) = Application.Transpose(RS.GetRows)
        iCount = iCount + 50
    Next
       
    RS.Close
    Set RS = Nothing
End Sub

.

meleklerim · 11 Nisan 2022

@Haluk Bey, kodlar harika çalışıyor, bundan iyisi şamda kayısı derler ya tıpkı onun gibi. Ama ilginç bir şekilde sizin gönderdiğiniz test sayfanızda bile verileri değiştirince çalışmadı F ve G sütunlarında hata verdi. ekte gönderiyorum, hatanın sebebini bulabilir misiniz? Bu arada sütun başlıklarını da otomatik alabilir mi?

Korhan Ayhan · 11 Nisan 2022

Siz tablonuzu nasıl kullanacağınızı belirtmezseniz bizler tabiri caizse kodu yazar geçeriz.

Bu tür sorularda en küçük detay bile çok önemlidir.

Kodun son halini deneyiniz.

C++:

Option Explicit

Sub Bolumleri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, X As Long, Son As Long, Say As Long
    Dim Y As Byte, WF As WorksheetFunction, Zaman As Double
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Set S1 = Sheets("Tablo")
    Set S2 = Sheets("Bölüm")
    Set WF = WorksheetFunction
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    S2.Cells.Clear
    
    Son = WF.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)
    
    Veri = S1.Range("A2:G" & Son).Value
    
    ReDim Liste(1 To S2.Rows.Count, 1 To 7)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" And Veri(X, 1) <> "SİCİL NO" Then
            If Not Dizi.Exists(Veri(X, 2)) Then
                Say = IIf(Say = 0, 1, Say + 49)
                Dizi.Add Veri(X, 2), Array(Say, 1)
                Liste(Say, 1) = Veri(X, 2) & " Bölümünde Çalışan Personeller Listesi"
                Say = Say + 1
                For Y = 1 To 7
                    Liste(Say, Y) = Veri(1, Y)
                    Liste(Say + 1, Y) = Veri(X, Y)
                Next
                Dizi.Item(Veri(X, 2)) = Array(Say + 1, 1)
            Else
                For Y = 1 To 7
                    Liste(Dizi.Item(Veri(X, 2))(0) + 1, Y) = Veri(X, Y)
                Next
                Dizi.Item(Veri(X, 2)) = Array(Dizi.Item(Veri(X, 2))(0) + 1, 1)
            End If
            Son = Dizi.Item(Veri(X, 2))(0)
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A1").Resize(Son, 7) = Liste
        Erase Liste
        Dizi.RemoveAll
        S2.Range("A2:G" & S2.Cells(S2.Rows.Count, 1).End(3).Row).AutoFilter 1, "SİCİL NO"
        S2.Range("A2:G" & S2.Cells(S2.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Font.Bold = True
        S2.Range("A2:G" & S2.Cells(S2.Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Interior.Color = 14277081
        If S2.AutoFilterMode Then S2.AutoFilterMode = False
        For X = 1 To S2.Cells(S2.Rows.Count, 1).End(3).Row
            If InStr(1, S2.Cells(X, 1), "Bölümünde Çalışan Personeller Listesi") > 0 Then
                With S2.Range("A" & X).Resize(1, 7)
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .Font.Bold = True
                    .Font.ColorIndex = 3
                End With
            End If
        Next
        S2.Columns.AutoFit
        Application.ScreenUpdating = True
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        Application.ScreenUpdating = True
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set WF = Nothing
    Set Dizi = Nothing
End Sub

Haluk · 11 Nisan 2022

İlk verdiğiniz tablo ile hata verdiğini söylediğiniz ikinci tablo, birbirine benzemekle birlikte sütunlardaki veri tiplerinde farklılık var. Gerekli revizyon ekli dosyada yapılmıştır.

Korhan Bey'e de katılıyorum......... Esasında, sormak istediğiniz asıl tabloyu örneklendirip en başta verseniz biz de boşuna zaman kaybetmemiş olurduk.

.

meleklerim · 11 Nisan 2022

@Korhan Ayhan Bey ve @Haluk Bey öncelikle her ikinizden de özür dilerim. Amacım tabi ki asla sizi yormak olamaz. Yapılacak herşeyi de size yaptırmamak adına, armut piş ağzıma düş mantığından uzaklaşmak adına tam olarak ne istediğimizi yazmıyoruz. Kaba olarak işin mantığını kavrasak biz de biraz kafa yorarak emek vererek birşeyler yaparsak hem sizi fazla yormamış oluruz diye düşünüyorum. Burada bazen öyle bazı sorular var ki sanki yardımcı olacak moderatörler, üyeler -afedersiniz- kendi çalışanıymış gibi herşeyi ondan istemiş. Bu duruma düşmemek adına hassasiyet gösterirken sizin daha da fazla yorulmanıza neden olmak da ayrı bir ironi olsa gerek. Tekrar özür diliyorum. Kodları denemedim henüz geri bildirimi yapmadan önce bunları yazmak istedim.

meleklerim · 11 Nisan 2022

@Haluk Bey, teşekkür ederim istediğim gibi olmuş, ama hücrelerdeki verilerin sonunda boşluklar oluşuyor. Bunu önlemenin yolu yok mu ya da şlem bittikten sonra tüm hücrelerde kırp işlemi gereçekleştirebilir mi?

meleklerim · 11 Nisan 2022

@Korhan Ayhan Bey, kodlar istediğim gibi çalışıyor, işlem bittikten sonra böüm sayfasında filtreler aktif kalıyor. onlar temizlenebilir mi?
Çok teşekkürler.
Not: şimdi farkettim
Tabloya bazı bölümler eklenip bazı kişilerin bölümleri değişip yeniden makro çalıştırıldığınca çok yanlış listelemeler yapıyor. İlk defa çalıştırılmasında sorun yok ancak üzerine çalıştırılınca listelre çok karışıyor.

Korhan Ayhan · 11 Nisan 2022

Kod her seferinde eski verileri silerek işlem yapıyor. Bu sebeple karışıklık olmaması gerekir.

#14 nolu mesajınızda bizi yormak istemediğinizi ifade etmenize rağmen filtre kaldırma işleminin düzeltilmesini talep etmeniz bir garip olmuş. Bu işleme ait kodları makro kaydet kullanarak ya da biraz araştırma yaparak elde edebilirsiniz.

Haluk · 11 Nisan 2022

meleklerim' Alıntı:
@Haluk Bey, teşekkür ederim istediğim gibi olmuş, ama hücrelerdeki verilerin sonunda boşluklar oluşuyor. Bunu önlemenin yolu yok mu ya da şlem bittikten sonra tüm hücrelerde kırp işlemi gereçekleştirebilir mi?

Kodun sonuna aşağıdaki kırmızı bölümü yapıştırıp, deneyin...

Rich (BB code):

    Next
   
    Addr = "Bölüm!A1:G" & iCount
    Range(Addr) = Evaluate("IF(" & Addr & "="""","""",TRIM(" & Addr & "))")
       
    RS.Close
    Set RS = Nothing
End Sub

.

Korhan Ayhan · 12 Nisan 2022

#12 nolu mesajımdaki koda filtreyi kaldıran kod satırını ekledim. Ayrıca listenin son bölümünde bir problem vardı. Bazı iyileştirmeler yaptım. Son halini tekrar deneyiniz.

meleklerim · 12 Nisan 2022

@Korhan Ayhan Bey, ve @Haluk Bey, teşekkür ederim, elinize sağlık. Her ikinizin de kodu istediğim gibi çalışıyor.

İstenilen sütundaki filtre sonuçlarının herbirini ayrı sayfalara kopyalama

meleklerim

Ekli dosyalar

Korhan Ayhan

Administrator

irfem4

Ekli dosyalar

irfem4

Ekli dosyalar

Haluk

Özel Üye

meleklerim

meleklerim

meleklerim

meleklerim

Haluk

Özel Üye

Ekli dosyalar

meleklerim

Ekli dosyalar

Korhan Ayhan

Administrator

Haluk

Özel Üye

Ekli dosyalar

meleklerim

meleklerim

meleklerim

Korhan Ayhan

Administrator

Haluk

Özel Üye

Korhan Ayhan

Administrator

meleklerim