Birden fazla sayfadan çoketopla

[obsesyonur]

Herkese iyi akşamlar,benim sorum;

Sayfa1'in, Sayfa2'nin ve Sayfa3'ün (A) sütunundaki değerleri tekrarsız olarak Sayfa4' e A1' den başlayarak sıralı olarak yazdırıp,yazdırılan bu değerlerin yanına yani (B) sütununa tüm sayfalardaki toplamını formül veya makro ile yazdırmaktır.
Örneğin tüm sayfalarda a değeri beş kerede geçse sayfa 4'ün a1 hücresine bir adet a değeri yazdırıp a değerinin tüm sayfalardaki sayısal değerinin toplamını b1 hücresine yazdırmak şeklinde özetleyebiliriz.

 

[YUSUF44]

Aşağıdaki kodlar her sayfanın A sütununu Sayfa4'ün A sütununa kopyalar. Yinelenenleri kaldırır ve her sayfanın B sütunundaki değerlerin toplamını Sayfa4'ün B sütununa aktarır:

Sub topla()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
Set s4 = Sheets("Sayfa4")
son1 = s1.Cells(Rows.Count, "A").End(3).Row
son2 = s2.Cells(Rows.Count, "A").End(3).Row
son3 = s3.Cells(Rows.Count, "A").End(3).Row
son4 = s4.Cells(Rows.Count, "A").End(3).Row
yeni = s4.Cells(Rows.Count, "A").End(3).Row + 1
If s4.Cells(yeni - 1, "a") = "" Then yeni = yeni - 1
s1.Range("A1:A" & son1).Copy s4.Cells(yeni, "A")
yeni = s4.Cells(Rows.Count, "A").End(3).Row + 1
If s4.Cells(yeni - 1, "a") = "" Then yeni = yeni - 1
s2.Range("A1:A" & son2).Copy s4.Cells(yeni, "A")
yeni = s4.Cells(Rows.Count, "A").End(3).Row + 1
If s4.Cells(yeni - 1, "a") = "" Then yeni = yeni - 1
s3.Range("A1:A" & son3).Copy s4.Cells(yeni, "A")
s4.Range("$A$1:$A$" & son1 + son2 + son3).RemoveDuplicates Columns:=1, Header:=xlNo
son4 = s4.Cells(Rows.Count, "A").End(3).Row
For i = 1 To son4
    s4.Cells(i, "B") = WorksheetFunction.SumIf(s1.Range("A1:A" & son1), s4.Cells(i, "A"), s1.Range("B1:B" & son1)) + _
                      WorksheetFunction.SumIf(s2.Range("A1:A" & son2), s4.Cells(i, "A"), s2.Range("B1:B" & son2)) + _
                      WorksheetFunction.SumIf(s3.Range("A1:A" & son3), s4.Cells(i, "A"), s3.Range("B1:B" & son3))
Next
End Sub

 

[obsesyonur]

Sayın Yusuf44 öncelikle soruma vermiş olduğunuz cevap için; biraz geç olmakla beraber, teşekkür ederim. Soruma cevaben verdiğiniz kodlar tam istediğim gibi çalışmakta,fakat örnekteki sayfa sayısı 4 değilde 400 olsa idi kodları tek tek her sayfa için ayrı ayrı yazmak oldukça zor görünüyor,bunun kolay bir yolu var mıdır?

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub topla()
Toplam = "yok"
For i = 1 To Sheets.Count
    If Sheets(i).Name = "Toplam" Then
        Toplam = "var"
    End If
Next

If Toplam = "yok" Then
    MsgBox "Dosyanızda Toplam sayfası bulunmamaktadır. " & Chr(10) & _
        "Öncelikle Toplam Sayfası oluşturmanız gerekmektedir.", vbCritical
    Exit Sub
Else
    Application.ScreenUpdating = False
    Set s1 = Sheets("Toplam")
    For sayfa = 1 To Sheets.Count
        If Sheets(sayfa).Name <> "Toplam" Then
            son = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row
            yeni = s1.Cells(Rows.Count, "A").End(3).Row + 1
            If s1.Cells(yeni - 1, "A") = "" Then yeni = yeni - 1
            Sheets(sayfa).Range("A1:A" & son).Copy s1.Cells(yeni, "A")
            yeni1 = s1.Cells(Rows.Count, "A").End(3).Row
            s1.Range("$A$1:$A$" & yeni1).RemoveDuplicates Columns:=1, Header:=xlNo
        End If
    Next
    son1 = s1.Cells(Rows.Count, "A").End(3).Row
    For j = 1 To son1
        sonuç = 0
        For k = 1 To Sheets.Count
            son2 = Sheets(k).Cells(Rows.Count, "A").End(3).Row
            sonuç = sonuç + WorksheetFunction.SumIf(Sheets(k).Range("A1:A" & son2), s1.Cells(j, "A"), Sheets(k).Range("B1:B" & son2))
        Next
        s1.Cells(j, "B") = sonuç
    Next
    Application.ScreenUpdating = True
End If
End Sub

 

[obsesyonur]

Sayın Yusuf44 cevabınız için çok teşekkür ederim,verdiğiniz makro kodunu toplam sayfasında oluşturduğum bir butona atayarak istediğim işlemi gerçekleştirebiliyorum,fakat söz konusu butona her tıkladığımda, değerleri bir kez daha topluyor,acaba sizin verdiğiniz koda bir ilave yapılarak, butona bastığımızda, toplam sayfasının içeriğini temizlese daha sonra verileri süzüp toplamlarını alsa,bu olanaklı mıdır?
Örnek dosya indirme linki : http://www.dosya.tc/server11/ggshxi/farkli_sayfalardan_veriler.rar.html

 

[YUSUF44]

Aşağıdaki gibi deneyin (dosyanıza bakmadım, eski kodu isteğinize göre güncelledim sadece):

Sub topla()
Toplam = "yok"
For i = 1 To Sheets.Count
    If Sheets(i).Name = "Toplam" Then
        Toplam = "var"
    End If
Next

If Toplam = "yok" Then
    MsgBox "Dosyanızda Toplam sayfası bulunmamaktadır. " & Chr(10) & _
        "Öncelikle Toplam Sayfası oluşturmanız gerekmektedir.", vbCritical
    Exit Sub
Else
    Application.ScreenUpdating = False
    Set s1 = Sheets("Toplam")
    eski = s1.Cells(Rows.Count, "A").End(3).Row
    s1.Range("A1:B" & eski) = ""
    For sayfa = 1 To Sheets.Count
        If Sheets(sayfa).Name <> "Toplam" Then
            son = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row
            yeni = s1.Cells(Rows.Count, "A").End(3).Row + 1
            If s1.Cells(yeni - 1, "A") = "" Then yeni = yeni - 1
            Sheets(sayfa).Range("A1:A" & son).Copy s1.Cells(yeni, "A")
            yeni1 = s1.Cells(Rows.Count, "A").End(3).Row
            s1.Range("$A$1:$A$" & yeni1).RemoveDuplicates Columns:=1, Header:=xlNo
        End If
    Next
    son1 = s1.Cells(Rows.Count, "A").End(3).Row
    For j = 1 To son1
        sonuç = 0
        For k = 1 To Sheets.Count
            son2 = Sheets(k).Cells(Rows.Count, "A").End(3).Row
            sonuç = sonuç + WorksheetFunction.SumIf(Sheets(k).Range("A1:A" & son2), s1.Cells(j, "A"), Sheets(k).Range("B1:B" & son2))
        Next
        s1.Cells(j, "B") = sonuç
    Next
    Application.ScreenUpdating = True
End If
End Sub

 

[obsesyonur]

Çözüldü;Birden fazla sayfadan çoketopla

Sayın Yusuf44 cevabınız ve göstermiş olduğunuz ilgi için çok teşekkür ederim,düzenlediğiniz makro kodu tam olarak istenilen şekilde çalışmaktadır,ayrıca ilgi duyduğum vba kodlama dilini öğrenmeye başlamak için nasıl bir yol izlemeliyim,önerinizi sabırsızlıkla bekliyorum.İyi geceler.