Phân tích vật tư khi dữ liệu trống (1 người xem)

[matran25251325]

Public Sub BUXULU()
Dim Rng As Range, Cll As Range, Sarr(), Darr(), I As Long, K As Long, Dic As Object, Dic2 As Object, Tem As String, Tem2 As String
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("TLuong DT")
Sarr = .Range(.[M10], .[M65000].End(xlUp)).Resize(, 4).Value
End With
ReDim Darr(1 To UBound(Sarr, 1), 1 To 4)
With Sheets("PhanTichVatTu")
Set Rng = .Range(.[G2], .[G2].End(xlDown))
For Each Cll In Rng
Dic2.Add UCase(Cll), ""
Next
For I = 1 To UBound(Sarr, 1)
Tem = UCase(Sarr(I, 1)): Tem2 = UCase(Sarr(I, 2))
If Not Dic2.Exists(Tem) And Not Dic2.Exists(Tem2) Then
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
Darr(K, 1) = K
Darr(K, 2) = Sarr(I, 1)
Darr(K, 3) = Sarr(I, 2)
Darr(K, 4) = Sarr(I, 4)
Else
Darr(Dic.Item(Tem), 4) = Darr(Dic.Item(Tem), 4) + Sarr(I, 4)
End If
End If
Next I
With .[A4]
.Resize(10000, 4).ClearContents
.Resize(10000, 4).Borders.LineStyle = xlNone
If K Then
.Resize(K, 4).Value = Darr
.Resize(K, 4).Borders.LineStyle = xlContinuous
End If
End With
End With
Set Dic = Nothing
Set Dic2 = Nothing
Set Rng = Nothing
End Sub

Với code trên và yêu cầu e có ghi trong file. Mong các anh giúp

 

[Ba Tê]

Public Sub BUXULU()
Dim Rng As Range, Cll As Range, Sarr(), Darr(), I As Long, K As Long, Dic As Object, Dic2 As Object, Tem As String, Tem2 As String
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("TLuong DT")
Sarr = .Range(.[M10], .[M65000].End(xlUp)).Resize(, 4).Value
End With
ReDim Darr(1 To UBound(Sarr, 1), 1 To 4)
With Sheets("PhanTichVatTu")
Set Rng = .Range(.[G2], .[G2].End(xlDown))
For Each Cll In Rng
Dic2.Add UCase(Cll), ""
Next
For I = 1 To UBound(Sarr, 1)
Tem = UCase(Sarr(I, 1)): Tem2 = UCase(Sarr(I, 2))
If Tem <> "" Then
If Not Dic2.Exists(Tem) And Not Dic2.Exists(Tem2) Then
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
Darr(K, 1) = K
Darr(K, 2) = Sarr(I, 1)
Darr(K, 3) = Sarr(I, 2)
Darr(K, 4) = Sarr(I, 4)
Else
Darr(Dic.Item(Tem), 4) = Darr(Dic.Item(Tem), 4) + Sarr(I, 4)
End If
End If
End If
Next I
With .[A4]
.Resize(10000, 4).ClearContents
.Resize(10000, 4).Borders.LineStyle = xlNone
If K Then
.Resize(K, 4).Value = Darr
.Resize(K, 4).Borders.LineStyle = xlContinuous
End If
End With
End With
Set Dic = Nothing
Set Dic2 = Nothing
Set Rng = Nothing
End Sub

Với code trên và yêu cầu e có ghi trong file. Mong các anh giúp

Là sao, muốn có dòng trống hay không có?
Nếu bỏ dòng trống thì thêm 2 dòng màu đỏ vào Sub bên trên thử xem.