Hesap kodlarının ayrı sayfalarda gösterilmesi

[1903emre34@gmail.com]

Merhaba,

"Sheet1" sayfasında hesap kodlarının, ayrı sayfalarda gösterilmesinin istiyorum, aşağıdaki kod çalışmadı. (istenen 100,102 sayfalarda yapılmıştır.)

http://s9.dosya.tc/server2/1xutva/hesap_kodlari.zip.html

Sub SAYFA_OLUŞTUR_AKTAR()
Set ana = Sheets("Sheet1"): ana.Activate
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
        If Worksheets.Count = 1 Then GoTo 20
50          For sayfa = 1 To Worksheets.Count
                On Error GoTo 50
                    If Sheets(sayfa).Name <> "Sheet1" Then Sheets(sayfa).Delete
                        Next
                            ilksat = WorksheetFunction.Match("HESAP KODU:", ana.Range("A:A"), 0)
                                ana.Range("I:I").ClearContents
                                    For sat = ilksat To ana.[B65536].End(3).Row
                                        If ana.Cells(sat, 1) = "HESAP KODU:" Then
                                            ana.Cells(sat, 9) = Left(Cells(sat, 2), 3)
                                                Else
                                                    ana.Cells(sat, 9) = ana.Cells(sat - 1, 9)
                                                        End If
                                                            Next
20                                                      For satır = ilksat To ana.[B65536].End(3).Row
                                                    If ana.Cells(satır, 9) <> ana.Cells(satır - 1, 9) Then
                                                Set syf = ThisWorkbook.Sheets.Add(After:= _
                                            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                                        syf.Name = ana.Cells(satır, 9)
                                topsat = satır + WorksheetFunction.CountIf(ana.Range("I:I"), syf.Name) - 1
                            ana.Range(ana.Cells(satır, 1), ana.Cells(topsat, 8)).Copy
                        syf.Activate: ActiveSheet.Paste: Cells.EntireColumn.AutoFit
                    Application.CutCopyMode = False: syf.[A1].Select: ana.Activate
                End If
10:         Next: ana.Range("I:I").ClearContents
        Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "ANA HESAP KODLARI İÇİN AYRI SAYFALAR OLUŞTURULDU" & vbLf & _
"VERİLER İLGİLİ SAYFALARA AKTARILDI", vbInformation, "1903emre34"
End Sub

 

[Asri]

Alternatif ;

Toplu hesapların olduğu sayfanın adı "Muavin" olmalı.
Diğer bütün sayfalar silinecektir.

Sub menu()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Call sayfasil
  Call hesaplar
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Sub sayfasil()
  For i = Sheets.Count To 2 Step -1
    If Sheets(i).Name <> "Muavin" Then Sheets(i).Delete
  Next i
End Sub
  
Sub hesaplar()
   Set sh = Sheets("Muavin")
   sonsatir = sh.Cells(Rows.Count, "A").End(3).Row
   satir = 4
   For i = 4 To sonsatir
     sh.Select
     veri = sh.Cells(i, 1).Value
     
     If veri = "HESAP KODU:" Then
       hesap = sh.Cells(i, 3).Value
       hesap = Left(hesap, InStr(hesap, " ") - 1)
     End If
     
     If eskihesap <> hesap And hesap <> Empty Then
        Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
        satir = 4
        newsh.Name = hesap
        eskihesap = hesap
        sh.Select
        Rows(i).Select
        Selection.Copy
        newsh.Select
        Rows("4:4").Select
        ActiveSheet.Paste
        Range("A7").Select
        Columns("A:A").ColumnWidth = 12.14
        Columns("C:C").ColumnWidth = 13.71
        Columns("D:D").ColumnWidth = 13.43
        Columns("F:F").ColumnWidth = 16.57
     Else
        satir = satir + 1
        Rows(i & ":" & i).Select
        Selection.Copy
        newsh.Select
        Rows(satir & ":" & satir).Select
        ActiveSheet.Paste
        Range("A7").Select
     End If
   Next i
End Sub