Çözüldü Tabloda belli başlıklara kadar seçmek ve seçilen yeri başka sayfaya kaydetmek

[uyecik]

Başlıkta yazdığım gibi Bir tablom var.
Bu tablonun belli bir kısmına kadar veriler var ve ardından Tekrar isim soy isim gibi başlıklar ve altında yine veriler var. Bu böyle 1000 lerce satır olarak devam ediyor. Fakat her başığın altındaki verilerin bulunduğu satır sayısı eşit değil. Kiminde bir başlığa kadar 50 satır kiminde 70-100-140 vs gibi. Ama benim bu başlıklara kadar seçip seçtiğim verileri başlıklar ile birlikte başka bir sayfaya taşımam gerekiyor. Bunun için bir çözüm var mıdır arkadaşlar?

 

[uyecik]

Arkadaşlar bu konu da yardımcı olabilecek yok mu? Veya konuyu mu anlatamadım?

 

[Ömer]

Merhaba,
Örnek dosya ekleyerek daha detaylı açıklamanızı rica ederim.

 

[uyecik]

Ana Sayfadaki tüm listeyi bu şekilde ayırmaya çalışacağım. Tabi bunun gibi de en az 50 dosyam daha var

 

[Ömer]

Bu şekilde deneyin.

Kodlar önce Ana Sayfa dışındaki sayfaları siler. Bu yüzden silinmemesini istediğiniz sayfa varsa; (örneğin excel sayfası)
If .Name <> "Ana Sayfa" Then satırını,
If .Name <> "Ana Sayfa" and .Name <> "excel" Then
olarak değiştirin.

Sub Duzenle()

    Dim Sa As Worksheet, son As Long, i As Integer, sat As Long, c As Range, Adr As String, s As Long

    Set Sa = Sheets("Ana Sayfa")
    son = Sa.Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = Worksheets.Count To 1 Step -1
        With Sheets(i)
            If .Name <> "Ana Sayfa" Then
                .Delete
            End If
        End With
    Next i
    
    sat = 1
    Set c = Sa.[A:A].Cells.Find("SIRA NO", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            Sheets.Add After:=ActiveSheet
            s = c.Row
            If c.Row = 1 Then s = son + 1
            Sa.Range(Sa.Cells(sat, "A"), Sa.Cells(s - 1, "D")).Copy Range("A1")
            Columns("A:D").EntireColumn.AutoFit
            sat = s
            Set c = Sa.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    MsgBox "Düzenleme Bitti.", , "excel.web.tr"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

 

[uyecik]

Ömer bey;
Yardımınız için teşekkür ederim. Ama maalesef excel kitleniyor. Bir ara hareket eder gibi olduğunda Sayfa 5400 gibi bir şey görebildim. Ayrı ayrı 5400 sayfa açmış yani bir hata var. Verdiğim örnek excel'den gidersek 48 adet sayfa açması gerekir. Çünkü 48 adet "SIRA NO" kelimesi geçiyor.

 

[Ömer]

Verdiğiniz örneği ben denedim. 48 sayfa açtı. Hata vermedi.
Farklı bir sayfa yapısında kodları denediyseniz denediğiniz dosyayı eklermişsiniz.

 

[uyecik]

Yok daha diğerlerinde denemedim. Anladığım kadarı ile "Ana Sayfa" nın içerisine yapıştırmamız gerekiyor diye düşündüm ve oraya yapıştırıp deniyorum. Ama aynı şekilde yine kitliyor. Kodları koyduğum şekilde dosyayı atayım belki yanlış yere yapıştırıyorum dur.

 

[uyecik]

Bu şekilde deneyin.

Kodlar önce Ana Sayfa dışındaki sayfaları siler. Bu yüzden silinmemesini istediğiniz sayfa varsa; (örneğin excel sayfası)
If .Name <> "Ana Sayfa" Then satırını,
If .Name <> "Ana Sayfa" and .Name <> "excel" Then
olarak değiştirin.

Sub Duzenle()

    Dim Sa As Worksheet, son As Long, i As Integer, sat As Long, c As Range, Adr As String, s As Long

    Set Sa = Sheets("Ana Sayfa")
    son = Sa.Cells(Rows.Count, "A").End(xlUp).Row
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = Worksheets.Count To 1 Step -1
        With Sheets(i)
            If .Name <> "Ana Sayfa" Then
                .Delete
            End If
        End With
    Next i
   
    sat = 1
    Set c = Sa.[A:A].Cells.Find("SIRA NO", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            Sheets.Add After:=ActiveSheet
            s = c.Row
            If c.Row = 1 Then s = son + 1
            Sa.Range(Sa.Cells(sat, "A"), Sa.Cells(s - 1, "D")).Copy Range("A1")
            Columns("A:D").EntireColumn.AutoFit
            sat = s
            Set c = Sa.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
   
    MsgBox "Düzenleme Bitti.", , "excel.web.tr"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub

Verdiğiniz örneği ben denedim. 48 sayfa açtı. Hata vermedi.
Farklı bir sayfa yapısında kodları denediyseniz denediğiniz dosyayı eklermişsiniz.

Ömer bey;
Bakabildiniz mi bilmiyorum ama F8 tuşu ile ilerlediğimde exceli de kontrol edebiliyorum. Bakıyorum ki bir sürü boş sayfa açıyor. Ana Sayfa daki veriler de bitmiyor. Dolayısıyla Açmaya devam ediyor gibi geldi.
Elbette biliyorum ki sıkıntılı bir soru ve cevaplamak zorunda değilsiniz ama benim için süreklilik arz eden büyük bir sıkıntı. Yardımcı olursanız gerçekten çok sevinirim.

 

[Korhan Ayhan]

Alternatif,

Option Explicit

Sub Sayfalara_Aktar()
    Dim S1 As Worksheet, Sayfa As Worksheet, Bul As Range, Adres As String
    Dim Say As Long, X As Long, Y As Long, Z As Long, S2 As Worksheet, No As Long
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Ana Sayfa")
    
    Application.DisplayAlerts = False
    
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> S1.Name Then Sayfa.Delete
    Next
    
    Application.DisplayAlerts = True

    Say = WorksheetFunction.CountIf(S1.Range("A:A"), "SIRA NO")
    
    For X = 1 To Say
        Y = Evaluate("=SMALL(IF('" & S1.Name & "'!A:A=""SIRA NO"",ROW('" & S1.Name & "'!A:A))," & X & ")")
        If X = Say Then
            Z = S1.Cells(S1.Rows.Count, 1).End(3).Row + 1
        Else
            Z = Evaluate("=SMALL(IF('" & S1.Name & "'!A:A=""SIRA NO"",ROW('" & S1.Name & "'!A:A))," & X + 1 & ")")
        End If
        Sheets.Add , ActiveSheet
        Set S2 = ActiveSheet
        No = No + 1
        S2.Name = "Liste-" & No
        S1.Range("A" & Y & ":D" & Z - 1).Copy S2.Range("A1")
        S2.Range("A:D").EntireColumn.AutoFit
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox Say & " adet sayfa oluşturulmuştur.", vbInformation
End Sub

 

[Ömer]

Ömer bey;
Bakabildiniz mi bilmiyorum ama F8 tuşu ile ilerlediğimde exceli de kontrol edebiliyorum. Bakıyorum ki bir sürü boş sayfa açıyor. Ana Sayfa daki veriler de bitmiyor. Dolayısıyla Açmaya devam ediyor gibi geldi.
Elbette biliyorum ki sıkıntılı bir soru ve cevaplamak zorunda değilsiniz ama benim için süreklilik arz eden büyük bir sıkıntı. Yardımcı olursanız gerçekten çok sevinirim.

Kodları Ana Sayfanın kod bölümünden silip, vba ekranındaki menülerden;
Insert / Module ekleyin. Açılan bu bölüme(module1) kodları yapıştırıp çalıştırın.

.

 

[uyecik]

Ömer bey ve Korhan bey;
Her ikiniz de teşekkür ederim. Her ikinizin verdiği kodları da kendi diğer dosyalarıma entegre etmeyi başardım. Aslında ben bu işlemi belki fonksiyonlar yardımı ile yapabiliriz diye düşünmüştüm. O yüzden zaten bu bölüme yazmıştım. Fonksiyon ile olabilseydi ne yaptığımı bende belki anlayabilirdim. Ama sonuç itibarı ile işimi gördüm ve ayrı ayrı ikinize de teşekkür ederim.
Eğer çok olmayacaksam bir soru daha sormak isterim. Çok problem değil sayfaları kontrol edip elle yapabiliyorum ama varsa bir yolu birim adını sayfa adı olarak verebiliyor muyuz?

 

[Ömer]

Bu şekilde deneyin.

Sub Duzenle()

    Dim Sa As Worksheet, son As Long, i As Integer, sat As Long, c As Range, Adr As String, s As Long, a As Integer

    Set Sa = Sheets("Ana Sayfa")
    son = Sa.Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = Worksheets.Count To 1 Step -1
        With Sheets(i)
            If .Name <> "Ana Sayfa" Then
                .Delete
            End If
        End With
    Next i
    
    sat = 1
    Set c = Sa.[A:A].Cells.Find("SIRA NO", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            a = a + 1
            Sheets.Add After:=ActiveSheet
            s = c.Row
            If c.Row = 1 Then s = son + 1
            ActiveSheet.Name = Left(Sa.Cells(sat + 1, "D"), 10) & "_" & a
            Sa.Range(Sa.Cells(sat, "A"), Sa.Cells(s - 1, "D")).Copy Range("A1")
            Columns("A:D").EntireColumn.AutoFit
            sat = s
            Set c = Sa.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
    MsgBox "Düzenleme Bitti.", , "excel.web.tr"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

 

[uyecik]

Bu şekilde deneyin.

Sub Duzenle()

    Dim Sa As Worksheet, son As Long, i As Integer, sat As Long, c As Range, Adr As String, s As Long, a As Integer

    Set Sa = Sheets("Ana Sayfa")
    son = Sa.Cells(Rows.Count, "A").End(xlUp).Row
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = Worksheets.Count To 1 Step -1
        With Sheets(i)
            If .Name <> "Ana Sayfa" Then
                .Delete
            End If
        End With
    Next i
   
    sat = 1
    Set c = Sa.[A:A].Cells.Find("SIRA NO", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            a = a + 1
            Sheets.Add After:=ActiveSheet
            s = c.Row
            If c.Row = 1 Then s = son + 1
            ActiveSheet.Name = Left(Sa.Cells(sat + 1, "D"), 10) & "_" & a
            Sa.Range(Sa.Cells(sat, "A"), Sa.Cells(s - 1, "D")).Copy Range("A1")
            Columns("A:D").EntireColumn.AutoFit
            sat = s
            Set c = Sa.[A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
   
    MsgBox "Düzenleme Bitti.", , "excel.web.tr"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub

Süpersiniz çok teşekkür ederim.