Süzülen verileri yeni sayfaya kopyalama

A

atrixum

Katılım
2 Ağustos 2006
Mesajlar
4
Excel Vers. ve Dili
excel 2002
Arkadaşlar Merhaba,
Sayfa 1 de süzdüğüm verileri macro ile nasıl yeni bir sayfaya istediğim bir yere kopyalayabilirim?
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Sadece Süzülen başlık ve alanlarmı aktarılacak yoksa Aktarmaya A1 hücresinden süzülmüş son alana kadar mı gidece körnek dosya eklerseniz daha iyi olur.
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
2 adet yeni moduül ekleyiniz, ve aşğıdaki kodları kopyalayınız.


Bu kodlar ile filtre olan (kulakçıklı sütunlar) Yeni sayfanın 6. satırndan itiabren yapıştrıılır. 3. satırına filtrelenmiş alanın başlığı yazar
Personel Adı: Ahmet Olanalar gibi

Kodları Filtreli alanını kopyalamak istediğiniz sayfa aktif sayfanız iken Araçlar mAkrolardan FiltreliAlanıYeniSayfaYap makrosunu çalıştırarak veya bir düğmeye atayarak kullanabilirsiniz.


1. module
Kod: 
Function Kriterler(BaslikAlti As Range) As String
Dim Filter As String
Filter = ""
On Error GoTo SON
With BaslikAlti.Parent.AutoFilter
If Intersect(BaslikAlti, .Range) Is Nothing Then GoTo SON
With .Filters(BaslikAlti.Column - .Range.Column + 1)
If Not .On Then GoTo SON
Filter = Replace(.Criteria1, "=", """", 2)
Filter2 = Replace(.Criteria2, "=", """", 2)

Select Case .Operator
Case xlAnd
Filter = Filter & " ve " & Filter2
Case xlOr
Filter = Filter & " veya " & Filter2
End Select

End With
End With
SON:
Kriterler = Filter
End Function

2.module
Kod: 
Sub FiltreliAlanıYeniSayfaYap()
Application.ScreenUpdating = False
sfAdi = ActiveSheet.Name: snc = ""
'Çalışma Sayfasında filtre uygulanmış mı?
If ActiveSheet.FilterMode = False Then GoTo FiltreYok
'Uygulanmışsa; süzülen kriterlerin başlıklarını ve değerlerini bulur
    Dim Suz As Variant                                   'Dizi değişkeni tanımla
    sonfiltsut = ActiveSheet.AutoFilter.Filters.Count    'Filtre uygulanmış sütun sayısı
    ReDim Suz(sonfiltsut)                                'Suz değişkenini, sonfiltsut değişkeni kadar boyutlandır
        For a = sonfiltsut To 1 Step -1                  'Son filtrelenenden ilk filtrelenene kadar döngü başlat
            If ActiveSheet.AutoFilter.Filters.Item(a).On Then       'Filtre açıksa (kulakçık mavi ise)
                c = c + 1                                           'c değerini bir artır
                stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column    'Sütun nosunu bul
                strno = ActiveSheet.AutoFilter.Range.Cells(a).Row       'Satır nosunu bul
                SuzBas = ActiveSheet.AutoFilter.Range.Cells(a).Value    'Hücre değerini bul
                SuzKrt = Kriterler(Cells(strno + 1, stnno))             'Kriter değerini bul
                Suz(c) = SuzBas & ": " & SuzKrt                         'Hücre ve kriter değerlerini diziye al
                snc = Suz(c) & ", " & snc                               'snc değişkenine ata
            End If                                                      'Kontrolden çık
        Next                                                            'bir sonraki filtrelenene bak

    'Filtrelenmiş Alanı yeni sayfaya kopyalar
    Cells.Copy:        Sheets.Add                           'kopyala ve sayfa ekle, eklenen sayfada;
    Cells.PasteSpecial Paste:=xlPasteColumnWidths           'kolon genişliklerini yapıştır
    Selection.PasteSpecial Paste:=xlPasteValues             'Değerleri            yapıştır
    Selection.PasteSpecial Paste:=xlPasteFormats            'Biçimleri            yapıştır
    'ActiveSheet.Paste   'herşeyi kopyalar                  'Hepsini              yapıştır
    Application.CutCopyMode = False                         'Kopyalama Modunu Kapat
    Rows("1:5").Select:                                     Selection.Insert Shift:=xlDown

    
    
    'oluşturulan yeni sayfanının baslik, kenarlık ve yazdırma alanlarını düzenler
    sonsut = Cells(6, 1).End(xlToRight).Column          'yeni sayfadaki son dolu sutun
                'sonsut = sonfiltsut
    sonsat = Cells(65536, 1).End(xlUp).Row                  'yeni sayfadaki son dolu satır
    Range(Cells(3, 1), Cells(3, sonsut)).Select:     Call BaslikSatiri     'Başlık satırını belirle ve biçimlendir.
    Cells(3, 1).Value = snc & " Raporudur"
    Cells.Select:                                                    Call KenarlikYok      'Belirlenen aralıktaki, kenarlıkları sil
    Range(Cells(6, 1), Cells(sonsat, sonsut)).Select:          Call KenarlikCiz      'Belirlenen aralığa kenarlık çiz
    'ActiveSheet.PageSetup.PrintArea = "$A$1:$K$" & sonsat
    Call KenarBosluk      'Sayfanın kenar boşluklarını belirle (Kağıtta)
    Cells(1, 1).Select                                      'A1 i seç
    Erase Suz
    Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
'        Sheets(1).Delete
    Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
    GoTo SON
    
FiltreYok:
    MsgBox "Bu Sayfada Filte Uygulanmamış", vbCritical + vbQuestion
SON:
Application.ScreenUpdating = True
MsgBox "tamamlandı"
End Sub


Private Sub BaslikSatiri()
    With Selection
        .HorizontalAlignment = xlCenter:        .VerticalAlignment = xlBottom
        .WrapText = False:          .Orientation = 0:                   .AddIndent = False
        .IndentLevel = 0:           .ShrinkToFit = False:               .ReadingOrder = xlContext
        .MergeCells = True:         .RowHeight = 20
    End With
    With Selection.Font
        .Name = "Arial Tur":        .Size = 12:                         .Strikethrough = False
        .Superscript = False:       .Subscript = False:                 .OutlineFont = False
        .Shadow = False:            .Underline = xlUnderlineStyleNone:  .ColorIndex = xlAutomatic
        .Bold = True
    End With
End Sub

Private Sub KenarBosluk()
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .Orientation = xlLandscape
    End With
End Sub

Private Sub KenarlikCiz()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

Private Sub KenarlikYok()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
 
A

atrixum

Katılım
2 Ağustos 2006
Mesajlar
4
Excel Vers. ve Dili
excel 2002
teşekkürler, Lakin

Kardeş Teşekkür ederim verdiğin bilgiler için. Lakin ben başlık istemiyorsam kodlardan hangilerini silmem lazım birde ben 6.satıdan itibaren değilde 10.satırdan itibaren yapıştırmak istersem hangi kodu değiştirmem lazım. tekrar çok teşekkürler
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Kod: 
Sub FiltreliAlanıYeniSayfaYap()
Application.ScreenUpdating = False
sfAdi = ActiveSheet.Name: snc = ""
ynStr = 2
'Çalışma Sayfasında filtre uygulanmış mı?
If ActiveSheet.FilterMode = False Then GoTo FiltreYok
'Uygulanmışsa; süzülen kriterlerin başlıklarını ve değerlerini bulur
    Dim Suz As Variant                                   'Dizi değişkeni tanımla
    sonfiltsut = ActiveSheet.AutoFilter.Filters.Count    'Filtre uygulanmış sütun sayısı
    ReDim Suz(sonfiltsut)                                'Suz değişkenini, sonfiltsut değişkeni kadar boyutlandır
        For a = sonfiltsut To 1 Step -1                  'Son filtrelenenden ilk filtrelenene kadar döngü başlat
            If ActiveSheet.AutoFilter.Filters.Item(a).On Then       'Filtre açıksa (kulakçık mavi ise)
                c = c + 1                                           'c değerini bir artır
                stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column    'Sütun nosunu bul
                strno = ActiveSheet.AutoFilter.Range.Cells(a).Row       'Satır nosunu bul
                SuzBas = ActiveSheet.AutoFilter.Range.Cells(a).Value    'Hücre değerini bul
                Suz(c) = SuzBas & ": " & SuzKrt                         'Hücre ve kriter değerlerini diziye al
                snc = Suz(c) & ", " & snc                               'snc değişkenine ata
            End If                                                      'Kontrolden çık
        Next                                                            'bir sonraki filtrelenene bak

    'Filtrelenmiş Alanı yeni sayfaya kopyalar
    Cells.Copy:        Sheets.Add                           'kopyala ve sayfa ekle, eklenen sayfada;
    Cells.PasteSpecial Paste:=xlPasteColumnWidths           'kolon genişliklerini yapıştır
    Selection.PasteSpecial Paste:=xlPasteValues             'Değerleri            yapıştır
    Selection.PasteSpecial Paste:=xlPasteFormats            'Biçimleri            yapıştır
    Application.CutCopyMode = False                         'Kopyalama Modunu Kapat
    
    If ynStr = 1 Then GoTo GEC
        Rows("1:" & ynStr - 1).Select:                   Selection.Insert Shift:=xlDown
    
    
    
GEC:
    'oluşturulan yeni sayfanının baslik, kenarlık ve yazdırma alanlarını düzenler
    sonsut = Cells(ynStr, 1).End(xlToRight).Column          'yeni sayfadaki son dolu sutun
                'sonsut = sonfiltsut
    sonsat = Cells(65536, 1).End(xlUp).Row                  'yeni sayfadaki son dolu satır
'    Range(Cells(3, 1), Cells(3, sonsut)).Select:     Call BaslikSatiri     'Başlık satırını belirle ve biçimlendir.
'    Cells(3, 1).Value = snc & " Raporudur"
    Cells.Select:                                                    Call KenarlikYok      'Belirlenen aralıktaki, kenarlıkları sil
    Range(Cells(ynStr, 1), Cells(sonsat, sonsut)).Select:          Call KenarlikCiz      'Belirlenen aralığa kenarlık çiz
    Call KenarBosluk      'Sayfanın kenar boşluklarını belirle (Kağıtta)
    Cells(1, 1).Select                                      'A1 i seç
    Erase Suz
    GoTo SON
    
FiltreYok:
    MsgBox "Bu Sayfada Filte Uygulanmamış", vbCritical + vbQuestion
SON:
Application.ScreenUpdating = True
MsgBox "tamamlandı"
End Sub


Private Sub KenarBosluk()
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .Orientation = xlLandscape
    End With
End Sub

Private Sub KenarlikCiz()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

Private Sub KenarlikYok()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
modulü değiştriniz.

Not: En üstteki ynStr değişkenine Hangi satıra kopyalanmasını istiyorsanız yazınız.
 
Z

zebeallic

Katılım
20 Şubat 2008
Mesajlar
1
Excel Vers. ve Dili
XP pro version 5.1.2600
ingilizce
hsayar kardeş

konuyu ben açmadım ama çok işime yaradı kodların teşekkürler.

yanlız şöyle bi durum var 50000 datanın arasından yaklaşık 30000 kadar bi filtrelme de makro tam çalışmıyor ... süzme yapılan sayfanın aynısını alıyor ...kritere uymayanları kopyaladığı yeni sayfa da hide ediyor...

bunun bi çözümü var mı acaba?
 
H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
zebeallic' Alıntı:
hsayar kardeş

konuyu ben açmadım ama çok işime yaradı kodların teşekkürler.

yanlız şöyle bi durum var 50000 datanın arasından yaklaşık 30000 kadar bi filtrelme de makro tam çalışmıyor ... süzme yapılan sayfanın aynısını alıyor ...kritere uymayanları kopyaladığı yeni sayfa da hide ediyor...

bunun bi çözümü var mı acaba?
Genişletmek için tıkla ...
Sorununuzu anlayamadım ama Kasttetiğiniz
Verilerini A:Z sütün aralığında ancak filtre kutucukları a:p sütünlarında ise r:z sütunlarını almaz. onun haricinde satır olarak almıyor diyorsanız bir fikrim yok.
 
Z

ziya

Katılım
8 Nisan 2005
Mesajlar
756
Excel Vers. ve Dili
Excel 2010 Türkçe
Sn hsayar
mesajı size yazmıştım , sağolsun Ferhat Pazarçevirdi sorunuma çözüm getirdi.
Selamlar,
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Üst