Sayfalarda yazılı değerleri, tek bir sayfaya toplamak..

[sacide44]

Arkadaşlar, yardımcı olacaklara şimdiden teşekkür ederim..

Birden fazla sayfada (Sheet) datalar var.
Bu sayfalardaki tüm bilgilerin, aynı excel dosyasındaki TOPLAM isimli başka bir Sayfa'da toplanmasını istiyorum. Yani, Ahmet bey'in yaptığı işlemler Ahmet isimli sayfada; Mehmet bey'in yaptığı işlemler Mehmet isimli sayfalarda iken, bunların tümünü tek bir sayfada görmek istiyorum.. Dataların tümü aynı formatta (tümünde aynı sütunlarda aynı bilgiler var.) Sayfalardaki değerlere ilave satırlar geldikçe, TOPLAM sayfasında da otomatik olarak yer alsın.. Datalar metinden oluşuyor, otomatik toplama vs. gerekmiyor, sadece bilgiler aynen girildiği şekilde gelecek..

Teşekkür ederim.

 

[Murat OSMA]

Merhaaba öncelikle hoş geldiniz demek istiyorum...

Örnek dosyanız var ise ekleyin, onun üzerinden bir şeyler yapmaya çalışalım olur mu ?

 

[sacide44]

Teşekkür ederim,

Dosyayı ekliyorum.

 

[Murat OSMA]

Sanırım bu kod işinizi görecektir...

Sub Emre()
    Dim syf As Worksheet
        For Each syf In Worksheets
            If syf.Name <> "TOPLAM" Then
                syf.Range("A2:M200").Copy Sayfa1.Range("A65536").End(3)(2, 1)
            End If
        Next syf
    Sayfa1.Columns.AutoFit
    Set syf = Nothing
End Sub

Not: TOPLAM sayfasının A1 hücresine No yazın...

 

[asi_kral]

Teşekkür ederim,

Dosyayı ekliyorum.

Merhaba
Sayfanın Kod bölümüne kopyalayın ve deneyin.
Sayfa açılışında otomatik tüm verileri alır.

Option Explicit
Private Sub Worksheet_Activate()
'Konu       :   Tüm Sayfaları Tek Sayfaya Topla
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Skype      :   m.batu.1967
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet, _
a As Long, b As Long, c As Long
Set asi = Sheets("TOPLAM")
Application.ScreenUpdating = False
asi.Range("A2:M" & Rows.Count).ClearContents
For a = 1 To Sheets.Count
If Sheets(a).Name <> "TOPLAM" Then
Set kral = Sheets(a)
b = kral.Range("A" & Rows.Count).End(xlUp).Row
c = asi.Range("A" & Rows.Count).End(xlUp).Row + 1
kral.Range("A2:M" & b).Copy Destination:=asi.Range("A" & c)
End If: Next
c = asi.Range("A" & Rows.Count).End(xlUp).Row + 1
asi.Range("A2:M" & c).Interior.Color = xlNone
asi.Range("A2:M" & c).Font.ColorIndex = xlAutomatic
asi.Range("A2:M" & c).Font.Bold = False
asi.Range("A2:M" & c).Font.Italic = False
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "asi_kral_1967"
End Sub

Bu kodu dener misiniz_?
Dosyanız Ekte.

 

[sacide44]

Murat ve Asi Kral kardeşlerime çok teşekkür ederim,

Zahmet oldu

 

[asi_kral]

Murat ve Asi Kral kardeşlerime çok teşekkür ederim,

Zahmet oldu

Kolay Gelsin.