• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücredeki Değerleri Aynı İsimdeki Sayfalara Dağıtma

O

OoParadiSeoO

Katılım
13 Temmuz 2013
Mesajlar
241
Excel Vers. ve Dili
Türkçe 2007
Arkadaşlar merhaba,

1.Sayfada A sütunundaki hücrelerde günler mevcut (A1:Pazartesi, A2:Cuma vs)
Ayrıca haftanın günlerinden oluşan 7 adet sayfa mevcut.
1.Sayfadaki A sütunundaki gunlerin olduğu satırları ilgili sayfalara aktaran makroya ihtiyacım var.

Yardımlarınız için şimdiden teşekkür ederim..
 
Merhaba,
Öncelikle isteğiniz anlaşılıyor ancak yazılan kodun dosyanızla uyumlu olabilmesi için dosya yapınızın bilinmesi gerekiyor. Örnek dosya paylaşırsanız yardımcı olacak arkadaş doğru şekilde yardım edebilir.
İyi çalışmalar...
 
Merhaba,
Sisteme dosya yükleyemedim, verdiğim örnek üzerinden yardımcı olunması benim için yeterli..
Kendi dosyama uyarlayacak kadar bilgim var teşekkür ederim:)
 
Siz bilirsiniz. Buyurunuz...
Kod: 
Sub Kod()
Set s1 = Sheets("Sayfa1")
For a = 1 To s1.Range("A65500").End(3).Row
    Set s2 = Sheets(s1.Cells(a, "A").Text)
    son = s2.Range("A65500").End(3).Row + 1
    s1.Rows(a).Copy s2.Rows(son)
Next
End Sub
İyi çalışmalar...
 
Çok teşekkür ederim istediğim tam olarak buydu bir türlü becerememiştim emeğinize sağlık..
İlave olarak şunları da yapması mümkün mü,

1)A sütunundaki verilere göre sayfaları kendi oluştursun
2)Oluşturduğu sayfalara ilk kez kopyalama yaparken başlıkla birlikte kopyalasın..

Teşekkürler,
 
Buyurunuz, iyi çalışmalar...
Kod: 
Sub Kod()
Set s1 = Sheets("Sayfa1")
For a = 2 To s1.Range("A65500").End(3).Row
    For Each sh In Sheets
        If sh.Name = s1.Cells(a, "A").Text Then
            son = sh.Range("A65500").End(3).Row + 1
            s1.Rows(a).Copy sh.Rows(son)
            GoTo sonra
        End If
    Next
    Set s2 = Worksheets.Add(After:=Sheets(Sheets.Count))
    s2.Name = s1.Cells(a, "A").Text
    s1.Activate
    s1.Rows(1).Copy s2.Rows(1)
    s1.Rows(a).Copy s2.Rows(2)
sonra:
Next
MsgBox "İşlem tamam."
End Sub
 
Üstad çok teşekkür ederim, başka arkadaşlarda faydalanır umarım.. Ellerine sağlık...
 
Üstad, makroyu 60 binlik datada çalıştırdım yaklaşık 10 dk sürdü.
"For Each sh In Sheets" döngüsünde, her bir veri aktarımında kendi sheet'ini bulana kadar sıradan bütün sheet'lere bakıyor..
Daha hızlı sonuç almak adına bunu farklı bir şekilde kurgulamak mümkün mü?
Teşekkürler,
 
O döngü A sütunundaki verinin sayfası olmadığında kod hatası vermesin diye kullanılıyor. Döngüsüz de kurgulanabilir ama o zaman da başka sorunlar oluşabiliyor. Yine de kodun başına ve sonuna aşağıdaki satırları eklerseniz bir nebze daha hızlı olacaktır.
Kod: 
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'
'KOD
'
Appliation.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
Alternatif;

Veriler sayfalara filtre yöntemiyle aktarılıyor. Bu sebeple daha hızlı sonuç veriyor.

Ana sayfanızın adını VERİ olarak varsaydım. Veri aralığınızı ise A-K sütun aralığı olarak varsaydım. Siz kendinize göre uyarlarsınız.

100.000 satır veride işlem bende yaklaşık 15-20 saniye arasında sonuçlandı.

Kod: 
Option Explicit

Sub Verileri_Sayfalara_Aktar()
    Dim S1 As Worksheet, Son As Long, Son_Sütun As Integer
    Dim S2 As Worksheet, X As Long, Zaman As Double
    Dim Veri_Satırı As Long, Son_Satır As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("VERİ")
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Son_Sütun = Columns.Count
    S1.Columns("A:A").Copy S1.Cells(1, Son_Sütun)
    S1.Columns(Son_Sütun).RemoveDuplicates Columns:=1, Header:=xlYes

    Son = S1.Cells(Rows.Count, Son_Sütun).End(3).Row

    For X = 2 To Son
        Set S2 = Nothing
        On Error Resume Next
        Set S2 = Sheets(S1.Cells(X, Son_Sütun).Text)
        On Error GoTo 0
        
        If Not S2 Is Nothing Then
            Son_Satır = S2.Cells(Rows.Count, 1).End(3).Row + 1
            S1.Range("A1:K" & Rows.Count).AutoFilter 1, S2.Name
            Veri_Satırı = S1.Cells(Rows.Count, 1).End(3).Row
            S1.Range("A2:K" & Veri_Satırı).Copy S2.Cells(Son_Satır, 1)
        Else
            Set S2 = Sheets.Add(After:=Worksheets(Worksheets.Count))
            S2.Name = S1.Cells(X, Son_Sütun).Text
            S1.Range("A1:K" & Rows.Count).AutoFilter 1, S2.Name
            S1.Range("A1").CurrentRegion.Copy S2.Range("A1")
        End If
    Next
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    S1.Columns(Son_Sütun).Delete
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Verileriniz sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Korhan Bey, alternatif öneriniz için çok teşekkür ederim bu yöntemle daha hızlı sonuç alabildim..

Şöyle bir durum var,

If Not S2 Is Nothing Then
Son_Satır = S2.Cells(Rows.Count, 1).End(3).Row + 1
S1.Range("A1:U" & Rows.Count).AutoFilter 2, S2.Name
Veri_Satırı = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:U" & Veri_Satırı).Copy S2.Cells(Son_Satır, 1)

Dosyamda bu alan hiç çalışmıyor. Çünkü mevcutta VERİ sheet'inden başka sheet yok.. Sheet'leri yukarıdaki koddan bir sonraki adımda kendisi oluşturuyor.
Kodu kısaltmak adına nasıl revize edebiliriz?
Teşekkürler,
 
Aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit

Sub Verileri_Sayfalara_Aktar()
    Dim S1 As Worksheet, Son As Long, Son_Sütun As Integer
    Dim S2 As Worksheet, X As Long, Zaman As Double
    Dim Veri_Satırı As Long, Son_Satır As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("VERİ")
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Son_Sütun = Columns.Count
    S1.Columns("A:A").Copy S1.Cells(1, Son_Sütun)
    S1.Columns(Son_Sütun).RemoveDuplicates Columns:=1, Header:=xlYes

    Son = S1.Cells(Rows.Count, Son_Sütun).End(3).Row

    For X = 2 To Son
        Set S2 = Sheets.Add(After:=Worksheets(Worksheets.Count))
        S2.Name = S1.Cells(X, Son_Sütun).Text
        S1.Range("A1:K" & Rows.Count).AutoFilter 1, S2.Name
        S1.Range("A1").CurrentRegion.Copy S2.Range("A1")
    Next
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    S1.Columns(Son_Sütun).Delete
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Verileriniz sayfalara aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Korhan bey çok teşekkür ederim gayet güzel sonuç aldım.. Mucit77, üstat sizede tekrar teşekkür ediyorum.. Ellerinize sağlık..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst