A ve B sutununda aynı olanları bul diger sayfaya gonder

[yeniyetme]

Meraba arkadaşlar... Forum sayfalarını dolaştım ama benim derdime derman olacak bir yöntem bulamadım. yardımcı olacağınızı düşünerek yazıyorum.


A VE B sutunundaki daha çoğaltılabilir. Anlaşılması amacından kısa yazdım.
Benim yapmak istediğim olay sayfada herhangi bir yere koyduduğum butona tıklanıldığında şekilde de görüldüğü gibi A sütunu ve B sutundaki aynı olan değerleri bul ve miktarlarını toplayarak sayfa ikide uygun bir yere yaz. Öyle bir makroyu bir türlü yazamadım. O kadar araştırmalar yaptım bulamadım. Şekil olarak çok basit gözüküyor ama içinden çıkılmıyor.
Bu site de emeği geçen herkese teşekkürler bana excel'i sevdirdiği için....

 

[Ömer]

Merhaba,

Örnek dosya ekleyebilirmisiniz..

 

[yeniyetme]

tabi hemen gönderiyorum

 

[yeniyetme]

yukarıda verdiğim örnek düzgün çıkmamış kusura bakmayın...
örnek bir dosya gönderiyorum.......

 

[yeniyetme]

Veya bu yazdıklarıma yakın bir dosya örneğide olur. Yeterki A sutunu ve B sutunu dediğim (örnek resimde) gibi olsun.......... toplama yapması da şart değil yani ......

 

[Ömer]

Merhaba,

Örnek dosya fonksiyonlarla yapılmıştır.Umarım işinize yarar..

 

[yeniyetme]

Merhaba,

Örnek dosya fonksiyonlarla yapılmıştır.Umarım işinize yarar..

ilginize çok teşekkür ederim. ilgilenip formulleri yazmışsınız.

ya ben bir kısmı düzgün izah edemememişim sanırım. siz harika şekilde formulleri hazırlamışsınız ama bir taneden fazla olanları sayfa ikiye toplattırmışsınız. (yani A sutunu ve B sutunu aynı olan birden fazla ise şeklinde olmuş .) yazımın ilk başına eklediğim resmi incelerseniz beni çok daha iyi anlayacağınızı düşünüyorum.
Bu arada tekrar teşekkür ederim.

 

[Ömer]

Merhaba,

Örnek dosyayı inceleyiniz. İstediğiniz bu mu?

 

[yeniyetme]

Merhaba,

Örnek dosyayı inceleyiniz. İstediğiniz bu mu?

evet istediğim buydu şu an işin mantığını çözmeye çalışıyorum. ve bu formuller üzerinde çalışıp makrosunu yazmaya çalışacağım.

çok sağolun....

 

[Ömer]

Rica ederim.

İyi çalışmalar..

 

[Necdet]

Merhaba,

Özet Tablo ile yapılmış çözüm. Formül ve Makro yok, işi excele bıraktım.

 

[Recep İpek]

Alternatif olarak aşağıdaki kodları inceleyebilirsiniz.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 3)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 1) & ":" & a(i, 2)
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    veri(n, 1) = a(i, 1)
                    veri(n, 2) = a(i, 2)
                    .Add z, n
                  End If
                    veri(.Item(z), 3) = veri(.Item(z), 3) + a(i, 3)
            End If
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "c")).ClearContents
s2.[a2].Resize(n, 3).Value = veri
''*******************************************
s2.Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[yeniyetme]

Ya bu kadar da yardım hiç beklemiyordum ya. Gerçekten çok şaşırdım.
Arkadaşlar hepinize ayrı ayrı teşekkür eder. Çalışmalarınızda başarılar dilerim.
Ben tekrar rahatsız ederim.

 

[yeniyetme]

Alternatif olarak aşağıdaki kodları inceleyebilirsiniz.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a2:c" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 3)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 1) & ":" & a(i, 2)
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    veri(n, 1) = a(i, 1)
                    veri(n, 2) = a(i, 2)
                    .Add z, n
                  End If
                    veri(.Item(z), 3) = veri(.Item(z), 3) + a(i, 3)
            End If
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "c")).ClearContents
s2.[a2].Resize(n, 3).Value = veri
''*******************************************
s2.Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

ARKADAŞLAR BU MAKRO A LARI B LERİ AYNI OLANLARI BULUYOR C LERİNİ TOPLAYARAK SAYFA İKİ YE ATIYOR.
BU MAKROYU B LERİ VE Q LARI AYNI OLANLARI BUL H LERİNİ TOPLAYARAK SAYFA İKİYE YAZACAK ŞEKİLDE NASIL DEĞİŞTİREBİLİRİZ. ACABA ?

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a2:q" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 3)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 2) & ":" & a(i, 17)
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    veri(n, 1) = a(i, 2)
                    veri(n, 2) = a(i, 17)
                    .Add z, n
                  End If
                    veri(.Item(z), 3) = veri(.Item(z), 3) + a(i, 8)
            End If
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "c")).ClearContents
s2.[a2].Resize(n, 3).Value = veri
''*******************************************
s2.Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[yeniyetme]

Recep Bey ilginize tekrar teşekkür ederim. Şu an bu kodları tam olarak çözebilmiş değilim o yüzden de sabahtan beri bu kodlarla uğraşıyorum ve istediğimi yapamadım.

isteğim eğer q satırı boş ise benzersizlerin listesine atmasın vede doğal olarak toplamlarını almasın kodda nasıl bir değişiklik yapmam gerekiyor acaba...
(Biraz Masraflı oluyorum ama mazur görün )

veya aşağıya yazdığım kodların ne işe yaradıklarını yazabilrmisiniz.

With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
z = a(i, 2) & ":" & a(i, 17)
If Not IsEmpty(z) Then
If Not .exists(z) Then
n = n + 1
veri(n, 1) = a(i, 2)
veri(n, 2) = a(i, 17)
.Add z, n
End If
veri(.Item(z), 3) = veri(.Item(z), 3) + a(i, 8)
End If
Next i
End With

 

[Recep İpek]

Örnek küçük bir dosya ekleyebilirmisiniz?

 

[yeniyetme]

Recep bey isteğiniz üzerine dosya ektedir..

 

[Recep İpek]

O zaman kodlarda aşağıdaki şekilde revize yapmak gerekiyor.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a2:q" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 3)
'*******************************************
With CreateObject("Scripting.Dictionary")   'Dictionary nesnesi yarat
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If Not IsEmpty(a(i, 17)) Then   'Q kolonu dolu ise
            z = a(i, 2) & ":" & a(i, 17) 'z değişkeninde b ve q kolonunu birleştir.
                If Not IsEmpty(z) Then   'z dolu ise
                    If Not .exists(z) Then  'Dictionary nesnesinde z yok ise
                        n = n + 1
                        veri(n, 1) = a(i, 2)    'veri dizisinin 1.kolonuna b kolonu bilgisi
                        veri(n, 2) = a(i, 17)   'veri dizisinin 2.kolonuna q kolonu bilgisi
                        .Add z, n       'Dictionary nesnesine ekle
                    End If
                        veri(.Item(z), 3) = veri(.Item(z), 3) + a(i, 8) 'veri dizisinin 3.kolonuna h kolonu bilgisin topla
                End If
        End If
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(2, "a"), s2.Cells(sat, "c")).ClearContents
s2.[a2].Resize(n, 3).Value = veri
''*******************************************
s2.Select
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[yeniyetme]

ilgi ve alakanıza çok teşekkür ederim...