Soru Kullanılan Malzeme Listesi Raporu,

[MrExcelMr]

Merhaba,

https://s5.dosya.tc/server3/df5m1r/Covid_Malzeme_Liste.rar.html

Dosyada iki farklı excel çalışma kitabı yer alıyor. Pivot ile yapmakta olduğumuz işlemi makro ile yapmak istiyoruz. Excel Makro konusunda uzman bilgi sahibi değerli arkadaşlarımızın vakti müsait olursa destek olabilirler mi. Teşekkürler.


Amaç,
Data Çalışma Kitabındaki işlem tarihlerini Malzeme No bilgisine göre S sütunundaki değerleri saydırarak, Günlük Takip Listesi çalışma kitabına Malzeme No bilgisine göre tarihlere ilgili sütunlara değerlerin toplamını yazdırmak istiyoruz.

Günlük Takip Listesi çalışma kitabı Sayfa2 de ise, İşlem yapan kullanıcıların S sütunundaki değerlerini saydırarak, ilgili Kullanıcıların işlem tarihlerini işlemesini istiyoruz.


"Bir arada olacağımız güzel günlere, tedbirlere uyduğumuz sürece yaklaşırız."
"Kuraları ihmal ederek, virüsün sosyal hayatımızı ele geçirmesine fırsat vermeyelim".

 

[Ziynettin]

Merhaba,

Kodu "Günlük Takip Listesi" dosyanız "Sayfa1" 'de deneyin....

Önemli; Data ve Günlük takip listesi dosyalarınız aynı klasörde olmalı.

Sub test()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "Data.xlsx"
GetObject (yol & dosya)
Set s1 = Workbooks(dosya).Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 2).End(3).Row

If son < 2 Then Exit Sub

Set dc = CreateObject("scripting.dictionary")
a = s1.Range("B1:S" & son).Value
   
    For i = 2 To UBound(a)
        krt = a(i, 1) & "|" & a(i, 9)
        dc(krt) = dc(krt) + 1
    Next i

Set s2 = Sheets("Sayfa1")
sat = s2.Cells(Rows.Count, 1).End(3).Row
sut = s2.Cells(1, Columns.Count).End(xlToLeft).Column
b = s2.Range("A1", s2.Cells(sat, sut)).Value
ReDim v(1 To UBound(b), 1 To UBound(b, 2))

    For i = 2 To UBound(b)
        s = s + 1
        For j = 3 To UBound(b, 2)
            krt = b(i, 1) & "|" & b(1, j)
            If dc.exists(krt) Then
                v(s, j - 2) = dc(krt)
            End If
        Next j
    Next i
 
s2.[C2].Resize(s, UBound(b, 2) - 2) = v

Windows(dosya).Visible = True
Workbooks(dosya).Close 0
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[MrExcelMr]

@Ziynettin Bey teşekkür ederiz.
Günlük Takip Listesi" dosyanız "Sayfa2" içinde destek olabilir misiniz. Sağlıklı günler dileriz.

 

[Ziynettin]

Sayfa2 verilerinize ait kod.

Sub test_2() ' Sayfa2
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "Data.xlsx"
GetObject (yol & dosya)
Set s1 = Workbooks(dosya).Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 2).End(3).Row

If son < 2 Then Exit Sub

Set dc = CreateObject("scripting.dictionary")
a = s1.Range("B1:S" & son).Value
    
    For i = 2 To UBound(a)
        krt = a(i, 14) & "|" & a(i, 9)
        dc(krt) = dc(krt) + 1
    Next i

Set s2 = Sheets("Sayfa2")
sat = s2.Cells(Rows.Count, 1).End(3).Row
sut = s2.Cells(1, Columns.Count).End(xlToLeft).Column
b = s2.Range("A1", s2.Cells(sat, sut)).Value
ReDim v(1 To UBound(b), 1 To UBound(b, 2))

    For i = 2 To UBound(b)
        s = s + 1
        For j = 2 To UBound(b, 2)
            krt = b(i, 1) & "|" & b(1, j)
            If dc.exists(krt) Then
                v(s, j - 1) = dc(krt)
            End If
        Next j
    Next i
  
s2.[B2].Resize(s, UBound(b, 2) - 1) = v

Windows(dosya).Visible = True
Workbooks(dosya).Close 0
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[MrExcelMr]

@Ziynettin Bey yardımlarınız ve desteğiniz için çok teşekkür ederiz. Sağlıklı günler.