Sekmelere Ayırma

[ismail-34]

Çok Excel Web ailesine selamlar saygılar..

Benim sorum çek sahibine k sütununda buluna çek sahibi ismine göre sekmeler açılıp ilgili satırların açılan sekmelere aktarılması ile ilgili olacak.

Böyle bir şey inanıın çok işime yarayacaktır.. dosyam linktedir..

İndir ÇEK SAHİBİNE GÖRE SEKMELERE AYIRMA

Dosyayı indir ÇEK SAHİBİNE GÖRE SEKMELERE AYIRMA

dosya.co

Hocalarıma saygılar sevgiler..

 

[Necdet]

Merhaba,

İnceleyiniz

 

[ismail-34]

Merhaba,

İnceleyiniz

Necdet hocam misal bende benzersiz sutun k sutunu.yani k sutundakileri degerlere gore sayfa / Tab acilmasini isyiyoeum.sizin kodda nereyi degistirmem gerekiyor.

 

[veyselemre]

Sub sayfalaraVeriAktar()
    Dim ky, s1 As Worksheet, son&
    Set s1 = Sheets("TÜM ÇEKLER")
    son = s1.Cells(Rows.Count, 1).End(3).Row
    With CreateObject("Scripting.Dictionary")
        For Each ky In s1.Range("K2:K" & son).Value
            If ky <> "" And Not .Exists(ky) Then
                .Item(ky) = Null
                If Evaluate("ISREF('" & ky & "'!A1)") = False Then
                    Sheets.Add(, Sheets(Sheets.Count)).Name = ky
                Else
                    Sheets(ky).Cells.Clear
                End If
            End If
        Next ky
        s1.Select
        For Each ky In .Keys
            s1.Range("A1:M1").AutoFilter Field:=11, Criteria1:=ky
            s1.Range("A1:M" & son).Copy Sheets(ky).Range("A1")
            Sheets(ky).Columns.AutoFit
        Next ky
        s1.Range("A1:M1").AutoFilter
    End With
End Sub

 

[ismail-34]

Sub sayfalaraVeriAktar()
    Dim ky, s1 As Worksheet, son&
    Set s1 = Sheets("TÜM ÇEKLER")
    son = s1.Cells(Rows.Count, 1).End(3).Row
    With CreateObject("Scripting.Dictionary")
        For Each ky In s1.Range("K2:K" & son).Value
            If ky <> "" And Not .Exists(ky) Then
                .Item(ky) = Null
                If Evaluate("ISREF('" & ky & "'!A1)") = False Then
                    Sheets.Add(, Sheets(Sheets.Count)).Name = ky
                Else
                    Sheets(ky).Cells.Clear
                End If
            End If
        Next ky
        s1.Select
        For Each ky In .Keys
            s1.Range("A1:M1").AutoFilter Field:=11, Criteria1:=ky
            s1.Range("A1:M" & son).Copy Sheets(ky).Range("A1")
            Sheets(ky).Columns.AutoFit
        Next ky
        s1.Range("A1:M1").AutoFilter
    End With
End Sub

Hocam Mükemmel Çalışıyor. Bir şey daha sorcam bunları ayrı bir excel dosyası olarak açan hatta bu dosyaların nereye kaydededeceğini soran başka bir versiyonuda olabilirmi.yani sekme yerine tek başına excel dosyası olsunlar anlamında..olmadı ben o açılan sekmeleri tek tek farklı kaydet deyip kaydederim zaten.

üyeliğiniz gibi gerçekten çok özelsiniz veysel hocam.