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

Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
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?
 
Son düzenleme:
Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
Arkadaşlar bu konu da yardımcı olabilecek yok mu? Veya konuyu mu anlatamadım?
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,
Örnek dosya ekleyerek daha detaylı açıklamanızı rica ederim.
 
Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
Ana Sayfadaki tüm listeyi bu şekilde ayırmaya çalışacağım. Tabi bunun gibi de en az 50 dosyam daha var
 

Ekli dosyalar

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
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.

Kod:
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
 
Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
Ö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

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
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.
 
Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
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.
 

Ekli dosyalar

Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
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.

Kod:
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.
 

Ekli dosyalar

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Alternatif,

Kod:
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

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Ö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.

.
 
Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
Ö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

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,196
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Bu şekilde deneyin.
Kod:
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
 
Katılım
23 Temmuz 2008
Mesajlar
79
Excel Vers. ve Dili
türkçe 2003
Bu şekilde deneyin.
Kod:
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.
 
Üst