Makro'ya İlave, Malzeme Hareket Listesi

[1Al2Ver]

Merhaba,

Ek'li dosyada mevcut makroda bir düzenleme ihtiyacı doğdu,

Aynı tarihte, birden fazla girişi olan, aynı isimli malzemeye ait bir sorun.

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Tablo aynen kalabilir, "I6:I" aralığı (GİREN TL) ve "J6:J" aralığı (ÇIKAN TL) formül ile olabilir.

Teşekkür ederim.

 

[Ziynettin]

Merhaba,
Çalışmanız sayfa1 de.

Option Explicit
Sub Analiz()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim a(), b(), c(), d As Object
Dim i As Long, Say As Long, x As Long
Dim Krt As String, Tarih_1 As Date, Tarih_2 As Date
Dim Devir As Double, Aranan As String, Devir_TL As Double
Application.ScreenUpdating = 0
Set s1 = ThisWorkbook.Worksheets("MALZEME_ÇIKIŞI")
Set s2 = ThisWorkbook.Worksheets("MALZEME_GİRİŞİ")
Set s3 = ThisWorkbook.Worksheets("sayfa1")
Set d = CreateObject("Scripting.Dictionary")

Tarih_1 = s3.[E3]: Tarih_2 = s3.[F3]: Devir = s3.[H3]
Aranan = s3.[D3]: Devir_TL = s3.[I3]

a = s2.Range("B2:J" & s2.Cells(Rows.Count, 2).End(3).Row)
b = s1.Range("A2:J" & s1.Cells(Rows.Count, 2).End(3).Row)

ReDim c(1 To UBound(a) + UBound(b), 1 To 11)
For i = 1 To UBound(a)
    If Aranan = a(i, 3) And Tarih_1 <= a(i, 1) And Tarih_2 >= a(i, 1) Then
        Krt = a(i, 1) & a(i, 3) & a(i, 4)
        If Not d.exists(Krt) Then
            Say = Say + 1
            d.Add Krt, Say
            c(Say, 1) = Say 'No
            c(Say, 2) = "G" 'Giriş
            c(Say, 3) = a(i, 1) 'Tarih
            c(Say, 4) = a(i, 3) 'Malzeme Cinsi
            c(Say, 5) = a(i, 4) 'Birim
        End If
        c(d(Krt), 6) = c(d(Krt), 6) + a(i, 5)
        c(d(Krt), 9) = c(d(Krt), 9) + a(i, 9)
End If
Next i

For i = 1 To UBound(b)
    If Aranan = b(i, 2) And Tarih_1 <= b(i, 1) And Tarih_2 >= b(i, 1) Then
        Krt = b(i, 1) & b(i, 3) & b(i, 3)
        If Not d.exists(Krt) Then
            Say = Say + 1
            d.Add Krt, Say
            c(Say, 1) = Say 'No
            c(Say, 2) = "Ç" 'Çıkış
            c(Say, 3) = b(i, 1) 'Tarih
            c(Say, 4) = b(i, 2) 'Malzeme Cinsi
            c(Say, 5) = b(i, 3) 'Birim
        End If
        c(d(Krt), 7) = c(d(Krt), 7) + b(i, 4)
        c(d(Krt), 10) = c(d(Krt), 10) + b(i, 5)
End If
Next i
s3.Range("A6:K" & Rows.Count).ClearContents
s3.Range("A6").Resize(Say, 11) = c
s3.Range("B6:K" & Say + 5).Sort s3.[C5], 1

For x = 6 To 6 + Say - 1
    s3.Cells(x, 8) = (WorksheetFunction.Sum(s3.Range("f6:f" & x)) _
            - WorksheetFunction.Sum(s3.Range("g6:g" & x))) + Devir
    s3.Cells(x, 11) = (WorksheetFunction.Sum(s3.Range("I6:I" & x)) _
            - WorksheetFunction.Sum(s3.Range("J6:J" & x))) + Devir_TL
Next x
Application.ScreenUpdating = 1
MsgBox "İşlem Tamam.", vbInformation
End Sub

 

[1Al2Ver]

Sayın Ziynettin merhaba,

İlginiz ve çözüm için teşekkür ederim, sağ olun.

Saygılarımla.