GTK-PM
Thành viên thường trực
- Tham gia
- 10/11/13
- Bài viết
- 313
- Được thích
- 15
Mã:
Option Explicit
Public Sub BC_HangMuc()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, Rws As Long
Dim KQ, Tam, T As Long
Dim fDate As Long, eDate As Long, MaHM As String, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("BC HANGMUC")
fDate = .Range("G6").Value
eDate = .Range("G7").Value
MaHM = .Range("J6").Value
End With
'-----------------------------------------------
With Sheets("DANHMUC")
sArr = .Range("C7", .Range("C65000").End(xlUp)).Resize(, 4).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 8)
For I = 1 To UBound(sArr)
If sArr(I, 1) <> Empty Then
K = K + 1: dArr(K, 1) = K
Dic.Item(sArr(I, 1)) = K
For J = 1 To 3
dArr(K, J + 1) = sArr(I, J)
Next J
End If
Next I
'-----------------------------------------------
With Sheets("NHAP")
sArr = .Range("D10", .Range("D10").End(xlDown)).Resize(, 16).Value
End With
For I = 1 To UBound(sArr)
If sArr(I, 1) <= eDate Then
If sArr(I, 1) >= fDate Then
If sArr(I, 16) = MaHM Then
If Dic.Exists(sArr(I, 3)) Then
Rws = Dic.Item(sArr(I, 3))
dArr(Rws, 6) = dArr(Rws, 6) + sArr(I, 13)
dArr(Rws, 8) = dArr(Rws, 6) - dArr(Rws, 7)
End If
End If
End If
End If
Next I
'--------------------------------------------
With Sheets("XUAT")
sArr = .Range("D10", .Range("D10").End(xlDown)).Resize(, 15).Value
End With
For I = 1 To UBound(sArr)
If sArr(I, 1) <= eDate Then
If sArr(I, 1) >= fDate Then
If sArr(I, 15) = MaHM Then
If Dic.Exists(sArr(I, 3)) Then
Rws = Dic.Item(sArr(I, 3))
dArr(Rws, 7) = dArr(Rws, 7) + sArr(I, 12)
dArr(Rws, 8) = dArr(Rws, 6) - dArr(Rws, 7)
End If
End If
End If
End If
Next I
'---------------------------------------------
ReDim KQ(1 To K + 1, 1 To 8)
For I = 1 To K
Tam = 0
For J = 5 To 8
Tam = Tam + dArr(I, J)
Next J
If Tam > 0 Then
T = T + 1
KQ(T, 1) = T
For J = 2 To 8
KQ(T, J) = dArr(I, J)
Next J
End If
Next I
'-----------------------
With Sheets("BC HANGMUC")
.Range("B12").Resize(450, 8).ClearContents
[COLOR=#ff0000][B] .Range("B12").Resize(T, 8) = KQ[/B][/COLOR]
Rows("12:450").Hidden = False
Rows([B450].End(xlUp).Offset(1).Row & ":450").Hidden = True
End With
Set Dic = Nothing
End SubXin hỏi lỗi mình đang bị là như thế nào vậy, và nhờ các bạn giúp đỡ mình cách sửa code trên !
Ảnh báo lỗi !
Link file lỗi đây : http://www.mediafire.com/download/ca5uz9vcnpkx9u6/KHO_DONGTHINH+T7+1.xlsm
Lần chỉnh sửa cuối:
