• FORUMU MOBİL UYGULAMADAN TAKİP EDİN

    Forumu isteyen üyelerimiz Tapatalk (Harici bir hizmet) üzerinden mobil uygulamadan takip edebilirler.
    iOS için : https://itunes.apple.com/app/id307880732?mt=8
    Android için : https://play.google.com/store/apps/details?id=com.quoord.tapatalkpro.activity
    adreslerinden indirebilirsiniz.

    Bir iki haftaya da foruma özel kendi uygulamamız yayında olacak.
ALTIN ÜYELİK Hakkında Bilgi
-----------------------

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

uyecik

Altın Üye
Altın Üye
Katılım
23 Temmuz 2008
Mesajlar
55
Beğeniler
3
Excel Vers. ve Dili
türkçe 2003
#1
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:

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
19,208
Beğeniler
27
Excel Vers. ve Dili
2010-Türkçe
#5
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
 

uyecik

Altın Üye
Altın Üye
Katılım
23 Temmuz 2008
Mesajlar
55
Beğeniler
3
Excel Vers. ve Dili
türkçe 2003
#6
Ö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
19,208
Beğeniler
27
Excel Vers. ve Dili
2010-Türkçe
#7
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

Altın Üye
Altın Üye
Katılım
23 Temmuz 2008
Mesajlar
55
Beğeniler
3
Excel Vers. ve Dili
türkçe 2003
#8
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

uyecik

Altın Üye
Altın Üye
Katılım
23 Temmuz 2008
Mesajlar
55
Beğeniler
3
Excel Vers. ve Dili
türkçe 2003
#9
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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
23,462
Beğeniler
48
Excel Vers. ve Dili
OFFICE 2013-2016 PRO TR
#10
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
19,208
Beğeniler
27
Excel Vers. ve Dili
2010-Türkçe
#11
Ö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

Altın Üye
Altın Üye
Katılım
23 Temmuz 2008
Mesajlar
55
Beğeniler
3
Excel Vers. ve Dili
türkçe 2003
#12
Ö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
19,208
Beğeniler
27
Excel Vers. ve Dili
2010-Türkçe
#13
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
 

uyecik

Altın Üye
Altın Üye
Katılım
23 Temmuz 2008
Mesajlar
55
Beğeniler
3
Excel Vers. ve Dili
türkçe 2003
#14
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