Nhờ chỉnh sửa VBA để đạt kết quả như theo mẫu (1 người xem)

[thuanntk]

Chào các bạn!
Nhờ các bạn chỉnh sửa VBA giúp mình để tính vật tư theo định mức sản xuất từng ngày để được kết quả như Sheet "Mẫu".
Cảm ơn các bạn

 

[thuanntk]

Có ai giúp mình được không vây??

 

[thnghiachau]

Có ai giúp mình được không vây??

Hết sức bình tĩnh bạn ah...
Bình tĩnh tự tin khong cay cú âm thầm chịu đựng... sẽ có người trả lời sau....

 

[sealand]

Bam thay Sub này vào Test xem sao:

Public Sub TINH()
    Dim Tm, Kq(1 To 10000, 1 To 4), i, k
        Dim Cl As Range, Addr As String
             Tm = Sheet2.Range("A2:C" & Sheet2.[A65536].End(3).Row)
                For i = 1 To UBound(Tm, 1)
                    With Sheet1.Range("A4:A65536")
                        Set Cl = .Find(Tm(i, 2), LookIn:=xlValues)
                            If Not Cl Is Nothing Then
                                Addr = Cl.Address
                                    Do
                                k = k + 1
                            Kq(k, 1) = Tm(i, 1)
                        Kq(k, 2) = Cl.Offset(, 1)
                    Kq(k, 3) = Cl.Offset(, 2) * Tm(i, 3)
                Kq(k, 4) = Tm(i, 2)
            Set Cl = .FindNext(Cl)
        Loop While Not Cl Is Nothing And Cl.Address <> Addr
    End If
End With
Next
Sheet3.[A3:D65536] = Kq
End Sub

 

[thuanntk]

Bam thay Sub này vào Test xem sao:

Public Sub TINH()
    Dim Tm, Kq(1 To 10000, 1 To 4), i, k
        Dim Cl As Range, Addr As String
             Tm = Sheet2.Range("A2:C" & Sheet2.[A65536].End(3).Row)
                For i = 1 To UBound(Tm, 1)
                    With Sheet1.Range("A4:A65536")
                        Set Cl = .Find(Tm(i, 2), LookIn:=xlValues)
                            If Not Cl Is Nothing Then
                                Addr = Cl.Address
                                    Do
                                k = k + 1
                            Kq(k, 1) = Tm(i, 1)
                        Kq(k, 2) = Cl.Offset(, 1)
                    Kq(k, 3) = Cl.Offset(, 2) * Tm(i, 3)
                Kq(k, 4) = Tm(i, 2)
            Set Cl = .FindNext(Cl)
        Loop While Not Cl Is Nothing And Cl.Address <> Addr
    End If
End With
Next
Sheet3.[A3:D65536] = Kq
End Sub

Ok rồi. Mình cảm ơn bạn nhiều nghe.