Nhờ các bác giúp em lập công thức tính định mức
- Thread starter tqb2412
- Ngày gửi
Viết code VBA cũng khá rối
Mã:
Sub DinhMuc()
Dim Sh As Worksheet, Q As Double
Dim sArr(), tArr(), dArr(), Arr(), Res(), S As Variant, S2 As Variant
Dim Dic As Object, Dic2 As Object, ikey As String
Dim eRow As Long, eCol As Long
Dim i As Long, j As Long, k As Long, ik As Long, jk As Long
Set Dic = CreateObject("scripting.dictionary")
Set Dic2 = CreateObject("scripting.dictionary")
For n = 1 To ActiveWorkbook.Sheets.Count
Set Sh = ActiveWorkbook.Sheets(n)
If Sh.Name <> "TOTAL" And Sh.Name <> "SUM" Then
eRow = Sh.Range("A1000000").End(xlUp).Row
eCol = Sh.Range("CCC1").End(xlToLeft).Column - 1
dArr = Sh.Range("A1").Resize(eRow, eCol).Value
k = k + 1
ReDim Preserve Arr(1 To k)
Arr(k) = dArr
For j = 5 To UBound(dArr, 2)
Dic2.Add (dArr(1, j)), Array(k, j)
Next j
End If
Next n
With Sheets("SUM")
eRow = .Range("A1000000").End(xlUp).Row
tArr = .Range("A1:GB" & eRow).Value
End With
ReDim sArr(1 To UBound(tArr, 1), 1 To UBound(tArr, 2))
k = 0
For i = 2 To UBound(tArr, 1)
If Len(tArr(i, 2)) > 0 Then
ikey = tArr(i, 1) & "#" & tArr(i, 2)
If Not Dic.exists(ikey) Then
k = k + 1
Dic.Add (ikey), k
For j = 1 To UBound(sArr, 2)
sArr(k, j) = tArr(i, j)
Next j
Else
ik = Dic.Item(ikey)
For j = 5 To UBound(sArr, 2)
sArr(ik, j) = sArr(ik, j) + tArr(i, j)
Next j
End If
Else
Dic.Item("zzz") = Dic.Item("zzz") & "," & i
End If
Next i
S = Split(Dic.Item("zzz"), ",")
For j = 5 To UBound(sArr, 2)
Dic.Add (tArr(1, j)), j
For n = 1 To UBound(S)
k = CLng(S(n))
Q = tArr(k, j)
If Q > 0 Then
S2 = Dic2.Item(tArr(k, 1))
If TypeName(S2) = "Variant()" Then
dArr = Arr(S2(0))
jk = S2(1)
For i = 2 To UBound(dArr)
If dArr(i, jk) > 0 Then
ik = Dic.Item(dArr(i, 1) & "#" & dArr(i, 2))
If ik Then
sArr(ik, j) = sArr(ik, j) + Q * dArr(i, jk)
End If
End If
Next i
End If
End If
Next n
Next j
With Sheets("TOTAL")
eRow = .Range("A1000000").End(xlUp).Row
.Range("E2:GC" & eRow).ClearContents
Res = .Range("A1:GC" & eRow).Value
k = UBound(Res, 2)
For i = 2 To UBound(Res, 1)
ik = Dic.Item(Res(i, 1) & "#" & Res(i, 2))
If ik > 0 Then
For j = 5 To k - 1
jk = Dic.Item(Res(1, j))
If jk > 0 Then
Res(i, j) = sArr(ik, jk)
Res(i, k) = Res(i, k) + Res(i, j)
End If
Next j
End If
Next i
.Range("A1").Resize(UBound(Res), k) = Res
End With
End SubĐầu tiên là em xin cám ơn bác đã giúp đỡ.
Tiếp theo thì em chả biết nói gì hơn. khủng khiếp quá.zzzz
Bác @HieuCD ơi. em xin lỗi vì đã làm phiền bác.
Sau thời gian em ngâm cứu code bác viết cho em. em mới nhận ra 1 điều là:
có những mã ko xuất hiện ở sheet SUM nhưng có ở các sheet khác thì ở sheet tổng hợp sẽ không lấy giá trị được.
Bác xem giúp em với.
Em cảm ơn.
Bài viết mới nhất
- Question
