Ayrı Sayfalardaki Aynı Olanlarını Bul Topla

[fdisk]

bul topla
ekteki örnek dosyı makro ile nasıl yapabilirim.
şimdiden teşekkürler.

 

[Ferhat Pazarçevirdi]

Merhabalar

Aşağıdakileri, standart bir modül sayfasına kopyalayınız. Daha sonra "Sayfa4"e bir buton yerleştirip, bu makroyu atayınız

Option Explicit
Sub Topla()
Dim sh As Worksheet, shG As Worksheet
Dim i%, j%, y%, k%
Set sh = ActiveSheet
y = 1
sh.Range("B2:IV" & sh.Cells(65536, 1).End(xlUp).Row).Clear
For i = 3 To sh.Cells(65536, 1).End(xlUp).Row
    For j = 1 To Sheets.Count
        y = y + 1
        If Sheets(j).Name <> sh.Name Then
           Set shG = Sheets(j)
           sh.Cells(2, y) = shG.Cells(1, 1)
           For k = 3 To shG.Cells(65536, 1).End(xlUp).Row
               If shG.Cells(k, 1) = sh.Cells(i, 1) Then
                  sh.Cells(i, y) = shG.Cells(k, 2)
               End If
           Next k
           Set shG = Nothing
        End If
    Next j
    y = 1
Next i
End Sub

 

[fdisk]

hocam malzemeleri otomatik olarak her sayfadan alacak aynı isimde olanları almayacak.
sonra her sayfadaki aynı olan kalemleri toplayarak yazacak

çok sağolun.

 

[Ferhat Pazarçevirdi]

O zaman kodu şöyle revize etmeliyiz.

Option Explicit
Sub Topla()
Dim sh As Worksheet, shG As Worksheet
Dim i%, j%, y%, k%, x%, z%
Dim arrMalzeme() As Variant
Set sh = ActiveSheet
sh.Cells.ClearContents
x = 1
ReDim Preserve arrMalzeme(1 To x)
For i = 1 To Sheets.Count
    If Sheets(i).Name <> sh.Name Then
       Set shG = Sheets(i)
       
       For j = 3 To shG.Cells(65536, 1).End(xlUp).Row
           
           For k = 1 To UBound(arrMalzeme)
               If shG.Cells(j, 1) = arrMalzeme(k) Then: z = z + 1
           Next k
           
           If z = 0 Then
              ReDim Preserve arrMalzeme(1 To x)
              arrMalzeme(x) = shG.Cells(j, 1)
              x = x + 1
           End If
           z = 0
       Next j
    
    End If
Next i
sh.Cells(2, 1) = "Malzemeler"
For i = 1 To UBound(arrMalzeme)
    sh.Cells(i + 2, 1) = arrMalzeme(i)
Next i
y = 1
sh.Range("B2:IV" & sh.Cells(65536, 1).End(xlUp).Row).Clear
For i = 3 To sh.Cells(65536, 1).End(xlUp).Row
    For j = 1 To Sheets.Count
        y = y + 1
        If Sheets(j).Name <> sh.Name Then
           Set shG = Sheets(j)
           sh.Cells(2, y) = shG.Cells(1, 1)
           For k = 3 To shG.Cells(65536, 1).End(xlUp).Row
               If shG.Cells(k, 1) = sh.Cells(i, 1) Then
                  sh.Cells(i, y) = shG.Cells(k, 2)
               End If
           Next k
           Set shG = Nothing
        End If
    Next j
    y = 1
Next i
End Sub

 

[Ferhat Pazarçevirdi]

Bir dakika... Bu kodlarda bir hata var. Kullanmayın lütfen ...

Sheet'lerde mükerrer kayıtlar var sanırım, bunları hesaba katmadık.

 

[Ferhat Pazarçevirdi]

Şimdi, revize edilmiş bu kodları kullanabilirsiniz. Her sayfada örneğin "AA" nı bir defa tekrar ettiğini düşünmüştüm ama değilmiş... Şimdi sayfada "AA"'ların toplamını alarak tanloya yansıtıyor.

NOT : Değişiklik kırmızı olarak gösterilen satırda yapılmıştır.

Option Explicit
Sub Topla()
Dim sh As Worksheet, shG As Worksheet
Dim i%, j%, y%, k%, x%, z%
Dim arrMalzeme() As Variant
Set sh = ActiveSheet
sh.Cells.ClearContents
x = 1
ReDim Preserve arrMalzeme(1 To x)
For i = 1 To Sheets.Count
    If Sheets(i).Name <> sh.Name Then
       Set shG = Sheets(i)
       
       For j = 3 To shG.Cells(65536, 1).End(xlUp).Row
           
           For k = 1 To UBound(arrMalzeme)
               If shG.Cells(j, 1) = arrMalzeme(k) Then: z = z + 1
           Next k
           
           If z = 0 Then
              ReDim Preserve arrMalzeme(1 To x)
              arrMalzeme(x) = shG.Cells(j, 1)
              x = x + 1
           End If
           z = 0
       Next j
    
    End If
Next i
sh.Cells(2, 1) = "Malzemeler"
For i = 1 To UBound(arrMalzeme)
    sh.Cells(i + 2, 1) = arrMalzeme(i)
Next i
y = 1
For i = 3 To sh.Cells(65536, 1).End(xlUp).Row
    For j = 1 To Sheets.Count
        y = y + 1
        If Sheets(j).Name <> sh.Name Then
           Set shG = Sheets(j)
           sh.Cells(2, y) = shG.Cells(1, 1)
           For k = 3 To shG.Cells(65536, 1).End(xlUp).Row
               If shG.Cells(k, 1) = sh.Cells(i, 1) Then
[COLOR=red]                  sh.Cells(i, y) = shG.Cells(k, 2) + sh.Cells(i, y)[/COLOR]
               End If
           Next k
           Set shG = Nothing
        End If
    Next j
    y = 1
Next i
End Sub

 

[Recep İpek]

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

[COLOR=blue]Sub[/COLOR] AktarTopla[COLOR=blue]()
[/COLOR]Dim a, b, c, d, i, n, veri()
Set s1 = Sheets("DEPO")
Set s2 = Sheets("SIPARIS")
Set s3 = Sheets("SEVK")
Set s4 = Sheets("RAPOR")
'*******************************************
a = s1.Range("a3:b" & s1.[b65536].End(3).Row).Value
b = s2.Range("a3:b" & s2.[b65536].End(3).Row).Value
c = s3.Range("a3:b" & s3.[b65536].End(3).Row).Value
d = s1.[a65536].End(3).Row + s2.[a65536].End(3).Row + s3.[a65536].End(3).Row
ReDim veri(1 To d, 1 To 5)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If Not IsEmpty(a(i, 1)) Then
            If Not .exists(a(i, 1)) Then
                n = n + 1
                veri(n, 1) = n
                veri(n, 2) = a(i, 1)
                .Add a(i, 1), n
            End If
                veri(.Item(a(i, 1)), 3) = veri(.Item(a(i, 1)), 3) + a(i, 2)
        End If
    Next i
    For i = 1 To UBound(b, 1)
        If Not IsEmpty(b(i, 1)) Then
            If Not .exists(b(i, 1)) Then
                n = n + 1
                veri(n, 1) = n
                veri(n, 2) = b(i, 1)
                .Add b(i, 1), n
            End If
                veri(.Item(b(i, 1)), 4) = veri(.Item(b(i, 1)), 4) + b(i, 2)
        End If
    Next i
    For i = 1 To UBound(c, 1)
        If Not IsEmpty(c(i, 1)) Then
            If Not .exists(c(i, 1)) Then
                n = n + 1
                veri(n, 1) = n
                veri(n, 2) = c(i, 1)
                .Add c(i, 1), n
            End If
                veri(.Item(c(i, 1)), 5) = veri(.Item(c(i, 1)), 5) + c(i, 2)
        End If
    Next i
End With
s4.Range("a4:e1000").ClearContents
s4.[a3].Resize(n, 5).Value = veri
'*******************************************
MsgBox "Bitti"
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
Set s3 = Nothing
Set s4 = Nothing
[COLOR=blue]End Sub
[/COLOR]

 

[fdisk]

Hepinizden Allah razı olsun.