Toplu Exceli sayfalara bölme

[igultekin2000]

İyi günler;
Müşteri cari hesaplarını sayfalı olarak muavin dökümünü alıyorum. Bazı cari hesaplar tek sayfa olduğu halde bazıları birkaç sayfa olabiliyor. Bunu da göze alarak toplu listeyi firmaya göre tekli(cariye) sayfalara bölme imkanı olabilir mi.? Her cari için firma ismiyle çalışma sayfa oluşturulabilir mi?

 

[YUSUF44]

Aşağıdaki makroyu deneyin. Verilerinizin çokluğuna göre işlem uzun sürebilir:

Sub cariayir()
Set s1 = Sheets("Sayfa5")
son = s1.Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False
    For i = 2 To son
        If s1.Cells(i, "A") = "İLGİLİ HESAP" Then
            For j = i + 1 To son
                If s1.Cells(j, "C") = "T O P L A M" Then
                    Sheets.Add
                    s1.Range("A" & i - 1 & ":J" & j).Copy ActiveSheet.[A1]
                    i = j
                    j = son
                End If
            Next
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[igultekin2000]

Teşekkür ederim, çalışma sayfası çok uzun olduğu halde, sorunsuz ve kısa sürede işlemi tamamladı. Buna bağlı olarak her sayfasın E2 hücresinde firmaların cari ismi oluyor. Onları boş bir sayfaya link olarak listelemek mümkün olabilir mi? İlgili firmaya kolay ulaşmak için. Teşekkür ederim.

 

[YUSUF44]

Dosyaya Linkler isimli bir sayfa ekleyin ve aşağıdaki makroyu deneyin:

Sub kopru()
Set s1 = Sheets("Sayfa5")
Set s2 = Sheets("Linkler")
s2.[A:B].Delete
a = 1
For i = 1 To Sheets.Count
    If Sheets(i).Name <> s1.Name And Sheets(i).Name <> s2.Name Then
        s2.Cells(a, "A") = a
        s2.Cells(a, "B") = Sheets(i).[E2]
        s2.Cells(a, "B").Hyperlinks.Add Anchor:=s2.Cells(a, "B"), Address:="", SubAddress:= _
        "'" & Sheets(i).Name & "'!A1"
        a = a + 1
        s2.[1:2].EntireColumn.AutoFit
    End If
Next
End Sub

 

[YUSUF44]

İki kodu birlikte kullanmak isterseniz şöyle olabilir:

Sub cariayir()
Set s1 = Sheets("Sayfa5")
Set s2 = Sheets("Linkler")
son = s1.Cells(Rows.Count, "A").End(3).Row

a = s2.Cells(Rows.Count, "A").End(3).Row + 1
Application.ScreenUpdating = False
    For i = 2 To son
        If s1.Cells(i, "A") = "İLGİLİ HESAP" Then
            For j = i + 1 To son
                If s1.Cells(j, "C") = "T O P L A M" Then
                    Sheets.Add
                    s1.Range("A" & i - 1 & ":J" & j).Copy ActiveSheet.[A1]
                    s2.Cells(a, "A") = a
                    s2.Cells(a, "B") = ActiveSheet.[E2]
                    s2.Cells(a, "B").Hyperlinks.Add Anchor:=s2.Cells(a, "B"), Address:="", SubAddress:= _
                        "'" & ActiveSheet.Name & "'!A1"
                    a = a + 1
                    i = j
                    j = son
                End If
            Next
        End If
    Next
    s2.[1:2].EntireColumn.AutoFit
    s2.Activate
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[igultekin2000]

Teşekkür ederim, link sayfası da sorunsuz çalışıyor. Emeğinize sağlık, iyi çalışmalar.

 

[igultekin2000]

Merhaba; Makroyu kullandım sorunsuz çalışıyor. Sayfalardaki firmayla çalıştıktan sonra oradan Linkler sayfasına kolay gitmek için mevcut makroya kod ilave olabilir mi? Teşekkür ederim.

 

[YUSUF44]

Aşağıdaki makro ilave olarak oluşturulan cari sayfasının I2:J2 hücrelerini birleştirerek Linkler sayfasına bağlantı verir:

Sub cariayir()
Set s1 = Sheets("Sayfa5")
Set s2 = Sheets("Linkler")
son = s1.Cells(Rows.Count, "A").End(3).Row

a = s2.Cells(Rows.Count, "A").End(3).Row + 1
Application.ScreenUpdating = False
    For i = 2 To son
        If s1.Cells(i, "A") = "İLGİLİ HESAP" Then
            For j = i + 1 To son
                If s1.Cells(j, "C") = "T O P L A M" Then
                    Sheets.Add
                    s1.Range("A" & i - 1 & ":J" & j).Copy ActiveSheet.[A1]
                    [I2:J2].Merge
                    [I2] = "Linkler"
                    [I2].Hyperlinks.Add Anchor:=[I2], Address:="", SubAddress:= _
                        "Linkler!A1"
                    s2.Cells(a, "A") = a
                    s2.Cells(a, "B") = ActiveSheet.[E2]
                    s2.Cells(a, "B").Hyperlinks.Add Anchor:=s2.Cells(a, "B"), Address:="", SubAddress:= _
                        "'" & ActiveSheet.Name & "'!A1"
                    
                    a = a + 1
                    i = j
                    j = son
                End If
            Next
        End If
    Next
    s2.[1:2].EntireColumn.AutoFit
    s2.Activate
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[igultekin2000]

Teşekkür ederim, sorunsuz çalışıyor. Emeğinize sağlık.

 

[Sedater06]

MERHABA YUSUF BEY BENIM DE BUNA BENZER BİR YARDIMA IHTIYACIM VAR.
DOSYAMI EK YAPTIM. HER 32 SATIRI BİR ÇALIŞMA SAYFASI YAPMAK İSTİYORUM.

ILGINIZ ICIN SIMDIDEN TEŞEKKÜR EDERİM.

Aşağıdaki makroyu deneyin. Verilerinizin çokluğuna göre işlem uzun sürebilir:

Sub cariayir()
Set s1 = Sheets("Sayfa5")
son = s1.Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False
    For i = 2 To son
        If s1.Cells(i, "A") = "İLGİLİ HESAP" Then
            For j = i + 1 To son
                If s1.Cells(j, "C") = "T O P L A M" Then
                    Sheets.Add
                    s1.Range("A" & i - 1 & ":J" & j).Copy ActiveSheet.[A1]
                    i = j
                    j = son
                End If
            Next
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[Necdet]

Merhaba,
Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.
Not : Sayfa adı olarak sayfa indisini kullandım, kodda göreceğiniz Sayfa1.range(....) ifadesi örneğinizde Sheets("Sheet") anlamındadır.
Açılan sayfaları da "A-001" gibi adlandırdım. bu adla sayfa varsa içini temizler öyle aktarır. Yoksa açıp aktarır.

Sub SayfalaraBol()

Dim rng As Range
Dim i   As Long
Dim lr  As Long
Dim syf As Integer
Dim sat As Integer
Dim sad As String

sat = 32

lr = Sayfa1.Cells(Rows.Count, "A").End(3).Row

Application.ScreenUpdating = False

For i = 1 To lr Step sat
    syf = syf + 1
    sad = "A-" & Format(syf, "000")
    If Not SayfaVar(sad) Then
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = sad
    Else
        Sheets(sad).UsedRange.Clear
    End If
    Sayfa1.Range("A" & i & ":A" & i + sat - 1).Copy Sheets(sad).Range("A1")
    Sheets(sad).Range("A1").ColumnWidth = Sayfa1.Range("A1").ColumnWidth
Next i

Sayfa1.Select
Application.ScreenUpdating = True
MsgBox syf & " ADET SAYFAYA BÖLÜNMÜŞTÜR....", vbInformation, "Necdet"
End Sub

Function SayfaVar(SayfaAdi As String) As Boolean

On Error Resume Next
SayfaVar = CBool(Len(Worksheets(SayfaAdi).Name) > 0)

End Function