Tüm sayfalardaki belirli veriyi TEK sayfada toplamak

[Yavuzdan]

Selamlar,
Müşteri Takip Tablomda, her müşteri için bir sayfa var. Bir Excel kitabında 250 sayfaya kadar müşteri sayfası açılabiliyor. (kahverengi sayfalar). Her müşteri sayfasinin 13. satırdan itibaren aşağı doğru görüşme notları var. Bütün müşteri sayfalarındaki bu görüşme notlarını tek "Ozet" sayfasında alt alta toplamam gerekiyor.

Her müşteri sayfasındaki "C1" hücresinde bulunan Müşteri Ünvanını, ilgili kayıtların başına getirmesi gerekiyor. Bir sayfadan ne kadar kayıt alırsa hepsinin başına o kayıta ait müşteri ünvanını getirmesini bir türlü başaramadım

Örnek Dosya ektedir.

Yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederim.

 

[Yavuzdan]

Lütfen Yardımm...

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub ÖZET_RAPOR()
    Dim SAYFA As Worksheet, SATIR As Long, X As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("ozet")
        .Range("A2:F65536").ClearContents
    
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Tab.ColorIndex = 40 Then
            SATIR = .Range("A65536").End(3).Row + 1
            For X = 13 To SAYFA.Range("A65536").End(3).Row
                .Cells(SATIR, 1) = SAYFA.Range("C1")
                .Cells(SATIR, 2) = SAYFA.Cells(X, 1)
                .Cells(SATIR, 3) = SAYFA.Cells(X, 2)
                .Cells(SATIR, 4) = SAYFA.Cells(X, 3)
                .Cells(SATIR, 5) = SAYFA.Cells(X, 5)
                .Cells(SATIR, 6) = SAYFA.Cells(X, 7)
                SATIR = SATIR + 1
            Next
        End If
    Next
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Yavuzdan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub ÖZET_RAPOR()
    Dim SAYFA As Worksheet, SATIR As Long, X As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("ozet")
        .Range("A2:F65536").ClearContents
    
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Tab.ColorIndex = 40 Then
            SATIR = .Range("A65536").End(3).Row + 1
            For X = 13 To SAYFA.Range("A65536").End(3).Row
                .Cells(SATIR, 1) = SAYFA.Range("C1")
                .Cells(SATIR, 2) = SAYFA.Cells(X, 1)
                .Cells(SATIR, 3) = SAYFA.Cells(X, 2)
                .Cells(SATIR, 4) = SAYFA.Cells(X, 3)
                .Cells(SATIR, 5) = SAYFA.Cells(X, 5)
                .Cells(SATIR, 6) = SAYFA.Cells(X, 7)
                SATIR = SATIR + 1
            Next
        End If
    Next
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan Ayhan Hocam elinize sağlık, İstediğim tamamen buydu..

Fakat!, Gerçek toplaya uyarladığımda "Run-time error '1004'" hatası aldım.
Asıl toplada Görüşme notlarının bulunduğu hücrede bir çok yerde 500 - 1000 karakteri bulan açıklama metinleri var. Buralara geldiğinde bu hatayı veriyor. 250 karakterin üstünde olduğundan dolayı veriyi aktaramıyor mu makro acaba..??

Bunu çözmenin bitr yolu, bir ek kodu varmıdır acaba..???

Çok telşekkürler..

Hocam Sorunu sanırım buldum.... Hücre içinde karakter sayısı "909" u geçince hata veriyor. 909 da hata yok. 5 karakter daha yazdığımda 914 yaptığımda hata veriyor..

909 karakter sınır mıdır..??? Nasıl aşarız hocam bunu.. Çok hücre var 1000 karakteri geçen...

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub ÖZET_RAPOR()
    Dim SAYFA As Worksheet, SATIR As Long, X As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("ozet")
        .Range("A2:F65536").ClearContents
    
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Tab.ColorIndex = 40 Then
            SATIR = .Range("A65536").End(3).Row + 1
            For X = 13 To SAYFA.Range("A65536").End(3).Row
                .Cells(SATIR, 1) = SAYFA.Range("C1")
                .Cells(SATIR, 2) = SAYFA.Cells(X, 1).Value
                .Cells(SATIR, 3) = SAYFA.Cells(X, 2).Value
                .Cells(SATIR, 4) = SAYFA.Cells(X, 3).Value
                .Cells(SATIR, 5) = SAYFA.Cells(X, 5).Value
                .Cells(SATIR, 6) = SAYFA.Cells(X, 7).Value
                SATIR = SATIR + 1
            Next
        End If
    Next
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Yavuzdan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub ÖZET_RAPOR()
    Dim SAYFA As Worksheet, SATIR As Long, X As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("ozet")
        .Range("A2:F65536").ClearContents
    
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Tab.ColorIndex = 40 Then
            SATIR = .Range("A65536").End(3).Row + 1
            For X = 13 To SAYFA.Range("A65536").End(3).Row
                .Cells(SATIR, 1) = SAYFA.Range("C1")
                .Cells(SATIR, 2) = SAYFA.Cells(X, 1).Value
                .Cells(SATIR, 3) = SAYFA.Cells(X, 2).Value
                .Cells(SATIR, 4) = SAYFA.Cells(X, 3).Value
                .Cells(SATIR, 5) = SAYFA.Cells(X, 5).Value
                .Cells(SATIR, 6) = SAYFA.Cells(X, 7).Value
                SATIR = SATIR + 1
            Next
        End If
    Next
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Hocam tamamdır... Elinize sağlık.

ilginiz ve yardımlarınız için teşekkür ederim.

Saygılarımla,

YavuZ