Sayfalardaki verileri aktarma

[SadiSerdari]

Arkadaşlar;çalışma kitabındaki tarihli sayfalarda yer alan belirli sütunları(B:I aralığındaki), sayfa9 sayfasına mükerrer olmayacak şekilde aktarmak istiyorum. Yardımcı olabilirseniz sevinirim. Teşekkürler.

 

[Bagcivan]

dosyanızı indiremiyorum fakat, veri sekmesindeki yinelenenleri kaldır veya gelişmiş işinizi görmüyor mu?

 

[SadiSerdari]

Sn. Bagcivan; Günlük girilen gıda ürünleri mevcut sütunlarda; bir aylık verileri kontrol edip benzer olanları bir defa yazarak aktarması gerekiyor. Sayfa9 diğer sayfalardaki gıda ürünleri adlarının bir araya getirileceği kısım. Her sayfadan tek tek bunları yazmak yerine makro yöntemi ile çözüme ulaşmak istedim. Eğer yardımlarınızla bunu gerçekleştirebilirsem çok iyi olacak.

 

[SadiSerdari]

Sevgili arkadaşlar çözüm konusunda yardımlarınızı bekliyorum. Normalde tekrar ileti yazmak hoş değil özür dilerim. Ancak acil olduğu için yazma gereği hissettim.

 

[SadiSerdari]

Arkadaşlar; aşağıdaki makro ile (Evren Bey'in yazmış olduğu bir makro idi yardımı oldu Teşekkürler.) sayfalardaki verileri aktarabiliyorum. Ancak aynı olan değerleri bir defa yazıp sayısal değerlerini nasıl toplamasını sağlayabilirim. Bu noktada yardımcı olabilirseniz sevinirim. Teşekkürler.

Sub Aktar()

    [A2:IV65536].Delete Shift:=xlUp
    Cells(2, 1).Select

    Application.ScreenUpdating = False

    sut = 2

    ReDim myarr(1 To Worksheets.Count - 13, 1 To Worksheets.Count * 65536)

        For Each sh In Worksheets

            If sh.Name <> "TOPLAM" Then
        
                sat = sh.Cells(Rows.Count, 1).End(xlUp).Row
                
                If sat > 2 Then
            
                    liste = sh.Range("A30:B" & sat).Value
            
                        For i = 1 To UBound(liste, 1)

                            n = n + 1

                            myarr(1, n) = liste(i, 1)
                            myarr(2, n) = liste(i, 2)

                        Next i
                        
                    Erase liste
                    
                End If

                sut = sut + 1
    
            End If

        Next sh
        
    If n > 1 Then

        ReDim Preserve myarr(1 To sut - 14, 1 To n)

        Range("A2").Resize(n, UBound(myarr, 1)) = Application.Transpose(myarr)
        Application.ScreenUpdating = True

    End If
    n = 0
    
    Application.ScreenUpdating = True

End Sub

 

[SadiSerdari]

Sevgili arkadaşlar hala çözüm önerilerinizi bekliyorum. Saygılarımla.

 

[SadiSerdari]

Arkadaşlar; Makroda biraz değişiklik yaptım, ancak yine istediğim sonucu elde edemedim.

    Sub Aktar()

        [A2:IV65536].Delete Shift:=xlUp
        Cells(2, 1).Select
       
        Set Tplm = Worksheets("TOPLAM")

        Application.ScreenUpdating = False

        Stn = 2
       
        Set Obj = CreateObject("Scripting.Dictionary")
        ReDim MyArr(1 To Worksheets.Count, 1 To Worksheets.Count * 100)

            For Each WrkSht In Worksheets

                If WrkSht.Name <> "TOPLAM" Then
           
                    SnStr1 = WrkSht.Cells(Rows.Count, 1).End(xlUp).Row
                   
                    If SnStr1 > 2 Then
               
                        MList = WrkSht.Range("A30:B" & SnStr1).Value
               
                            For i = 1 To UBound(MList, 1)
                           
                                If Not Obj.Exists(MList(i, 1)) Then

                                    n = n + 1
                                   
                                    Obj.Add MList(i, 1), n
                                   
                                        MyArr(1, n) = MList(i, 1)
                                        MyArr(2, n) = MList(i, 2)
                                                   
                                End If
                               
                                    MyArr(Stn, Obj.Item(MList(i, 1))) = MyArr(Stn, Obj.Item(MList(i, 1))) + MList(i, 2)

                            Next i
                           
                        Erase MList
                       
                    End If

                    Stn = Stn + 1
       
                End If

            Next WrkSht
           
        If n > 1 Then

            ReDim Preserve MyArr(1 To Stn - 1, 1 To n)

            Range("A2").Resize(n, UBound(MyArr, 1)) = Application.Transpose(MyArr)
            Application.ScreenUpdating = True

        End If
       
        Application.ScreenUpdating = True
       
        n = 0

    End Sub

MyArr(Stn, Obj.Item(MList(i, 1))) = MyArr(Stn, Obj.Item(MList(i, 1))) + MList(i, 2);
şeklinde yazarsam ilk sayfadaki ürünle ilgili değeri kendi ile topladıktan sonra toplama işlemine devam ediyor. Bununla Birlikte sayfa miktarı kadar sütunlara verilerin o sayfaki toplamını vererek devam ediyor. Benim yapmak istediğim sayfalardaki tüm verilerin değerlerinin toplamını tek sütunda görebilmek.
Sadece
MyArr(Stn, Obj.Item(MList(i, 1))) = MyArr(Stn, Obj.Item(MList(i, 1)))
şeklinde yazdığımda ise sadece ilk sayfanın toplamını veriyor.
Yardımcı olabilirseniz sevinirim. Teşekkürler.