Iki Calisma Sayfasini Ucuncu Calisma Sayfasinda Raporlamak

[cevocan]

Ocak Ayinda 100 Cesit Malzeme Giris Cikis Var
Subat Ayinda 200 Cesit Malzeme Giris Cikis Var

Ocak Ayi Ile Subat Ayi Hareketlerindeki Malzemelerden Ortak Olanlarda Var Her Iki Ayda Farkli Malzemelerde Var.

Ben Ucuncu Calisma Sayfasinda
A Sutununda Malzeme Adi
B Sutununda Ocak Ayindaki Miktari
C Sutununda Subat Ayindaki Miktar

Girecek.


Ucuncu Calisma Sayfasinda
Ocak Ayinda Hareket Yoksa Bos Yada Sifir Alacak. Haraeket Varsa Miktari Yazacak
Subat Ayinda Hareket Yoksa Bos Yada Sifir Alacak. Haraeket Varsa Miktari Yazacak


Bunun Icin Yardim.


Eger Mumkunce Acceess De Yapilabilirmi ?

 

[Ferhat Pazarçevirdi]

Merhabalar

Aşağıdaki kodu bir standart modül sayfasına kopyalayarak çalıştırınız.

Sub Getir()
Dim i%, j%, k%, y%, x%
Dim sh As Worksheet, shR As Worksheet
Dim bul As Range
Dim arrveri()
Set shR = Sheets("RAPOR")
shR.Range("B5:L10000").ClearContents
y = 1
For i = 1 To Sheets.Count
    Set sh = Sheets(i)
    If sh.Name <> "RAPOR" Then
       Set bul = sh.Columns(1).Find("Parça No", , , xlWhole)
       If Not bul Is Nothing Then
          If bul.Row = sh.Cells(65536, 1).End(xlUp).Row Then GoTo f1
             For j = bul.Row + 1 To sh.Cells(65536, 1).End(xlUp).Row
                 ReDim Preserve arrveri(1 To y)
                 For k = 1 To UBound(arrveri)
                     If arrveri(k) = sh.Cells(j, 1) Then: x = x + 1
                 Next k
                 If x = 0 Then
                    arrveri(y) = sh.Cells(j, 1)
                    y = y + 1
                 End If
                 x = 0
             Next j
       End If
    End If
f1:
Next i
For i = 1 To UBound(arrveri)
    shR.Cells(i + 4, 2) = arrveri(i)
    For j = 1 To Sheets.Count
        Set sh = Sheets(j)
            If sh.Name <> "RAPOR" Then
               Set bul = sh.Columns(1).Find(arrveri(i), , , xlWhole)
               If Not bul Is Nothing Then
                  shR.Cells(i + 4, 3 * j - 2) = sh.Cells(bul.Row, 3)
                  shR.Cells(i + 4, 3 * j - 1) = sh.Cells(bul.Row, 4)
               End If
            End If
    Next j
Next i
Set bul = Nothing
Set sh = Nothing
Set shR = Nothing
End Sub