süzme ve aktarma

[mavi.sakal333]

ekteki dosyada genel adında sayfa var, F sütununda 2009, 2010, 2011, 2012 yılları yazılı, ve ayrıca bunlara ait yeni sayfalarda mevcut.

benim istediğim genel sayfasındaki F sütunundaki yıllara göre süzmeyi yapsın o satır hangi yıla aitse o yılın sayfasında sıralansın. bununla ilgili bir makro yapabilirmisiniz. şimdiden teşekkür ederim.

 

[Saashii]

Makro yazmadan pivot table ile halledebilirsin diye düşünüyorum.
Ekli dosyadaki gibi.

 

[Necdet]

Merhaba,

Beğenirseniz aşağıdaki kodları kullanabilrsiniz.

Sub Suz_ve_Aktar()
    
    Dim i   As Long
    Dim j   As Integer
    Dim Kol As Integer
    Dim Syf As String
    Dim dz()
    
    Application.ScreenUpdating = False
    
    Kol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 2
    
    If ActiveSheet.AutoFilterMode = True Then Selection.AutoFilter
    
    i = Cells(Rows.Count, "B").End(3).Row
    
    Range("F3:F" & i).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, Kol) _
        , Unique:=True
        
    For j = 2 To Cells(Rows.Count, Kol).End(3).Row
        ReDim Preserve dz(j - 2)
        dz(j - 2) = Cells(j, Kol)
    Next j
    
    For j = 0 To UBound(dz)
        ActiveSheet.Range("$A$3:$J$" & i).AutoFilter Field:=6, Criteria1:=dz(j)
        Syf = dz(j)
        Range("A1").CurrentRegion.Offset(3, 1).Copy Sheets(Syf).Range("B4")
    Next j
    
    Columns(Kol).Delete
    
    Selection.AutoFilter
    
    Application.ScreenUpdating = True
    
    MsgBox "YILLARA GÖRE SÜZDÜM VE SAYFALARA AKTARDIM...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

 

[mavi.sakal333]

hata veriyo

Range("A1").CurrentRegion.Offset(3, 1).Copy Sheets(Syf).Range("B4")


şu satırda hata veriyor.

birleştirilmiş bir parçanın hücresi değiştirilmez diyor.
ilglendiğiniz için teşekkürler.

 

[mavi.sakal333]

Saashii , pivot table ile olmuyor çünkü; genel sayfasında 3000 den fazla kayıt girilecek ve her zaman süzme ve aktama işlemini yapması lazım, yani makro butonu olacak ve onu her tıkladığında bilgileri aktarmış olması gerekiyor. ilginden dolayı çok teşekkür ederim.

 

[Necdet]

Range("A1").CurrentRegion.Offset(3, 1).Copy Sheets(Syf).Range("B4")


şu satırda hata veriyor.

birleştirilmiş bir parçanın hücresi değiştirilmez diyor.
ilglendiğiniz için teşekkürler.

Buraya eklenen dosyada çalışıyor, örnek dosyanız asıl dosyanıza benzemiyor sanırım.

 

[endezyar]

farklı yaklaşım

İyi günler; verilerin çokluğu önemli değil.EKte sunduğum gibi tüm yılların icmali aynı yerde toplanır ve pivot uygulama yapılabilir.Örnek ektedir...

 

[mavi.sakal333]

makroda hata veriyor

Buraya eklenen dosyada çalışıyor, örnek dosyanız asıl dosyanıza benzemiyor sanırım.

sizin ekte gönderdiğiniz dosyayı çalıştırdığımda hatayı veriyordu.


şu satırda hata veriyor.


Range("A1").CurrentRegion.Offset(3, 1).Copy Sheets(Syf).Range("B4")


makro hata açıklaması: birleştirilmiş bir parçanın hücresi değiştirilmez diyor.

 

[mavi.sakal333]

Sayın Necdet bey; ekte gönderdiğiniz dosyayı hiç değiştirmeden çalıştırdığım halde hata verdi, tekrar bi bakabilirseniz sevinirim...

 

[Necdet]

Sayın Necdet bey; ekte gönderdiğiniz dosyayı hiç değiştirmeden çalıştırdığım halde hata verdi, tekrar bi bakabilirseniz sevinirim...

Merhaba

Ben 2007 sürüm ile bakıyorum sorun yok.

 

[Ömer]

Necdet bey,

2007 ve üst versiyonda çalışıyor fakat 2003 de "Birleştirilmiş hücre" hatası veriyor.

Sayın mavi.sakal333,

Alternatif olarak aşağıdaki gibi kullanabilirsiniz.

Sub Sayfalara_Dagit()
 
    Dim syf, i As Long, j As Long
 
    Application.ScreenUpdating = False
    Sheets("GENEL").Select
 
    For i = 1 To Worksheets.Count
        With Sheets(i)
            If .Name <> "GENEL" And .Name <> "Toplam İcmal" Then
                .Range("B4:J303").ClearContents
            End If
        End With
    Next i
 
    For i = 4 To Cells(Rows.Count, "F").End(xlUp).Row
        syf = Trim(Cells(i, "F"))
        With Sheets(syf)
            j = .Cells(Rows.Count, "F").End(xlUp).Row + 1
            Range("B" & i, "J" & i).Copy .Cells(j, "B")
        End With
    Next i
 
    MsgBox "Aktarım Tamamlandı.", , "excel.web.tr"
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[mavi.sakal333]

Ömer Bey çok teşekkür ederim istediğim oldu. Necdet bey sizede çok teşekkür ederim.