Bạn xem thử. Cái Tồn đầu kỳ mình không biết làm
Sub tonghop()
Dim sArr(), tArr(), dArr(), I As Long, K As Long
Dim Dic As Object, Tem As String, R As Long
Dim Thang As Long, Nam As Long
Thang = Sheet3.Range("B2"): Nam = Sheet3.Range("D2")
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
tArr = .Range("A3", .Range("F65535").End(3)).Value
End With
For I = 1 To UBound(tArr)
Tem = Month(tArr(I, 1)) & Year(tArr(I, 1)) & tArr(I, 5)
Dic.Item(Tem) = I
Next I
With Sheet2
sArr = .Range("A3", .Range("F65535").End(3)).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 5)
For I = 1 To UBound(sArr)
If Month(sArr(I, 1)) & Year(sArr(I, 1)) = Thang & Nam Then
Tem = Month(sArr(I, 1)) & Year(sArr(I, 1)) & sArr(I, 5)
R = Dic.Item(Tem)
If R Then
K = K + 1
dArr(K, 1) = tArr(R, 5)
dArr(K, 3) = tArr(R, 6)
dArr(K, 4) = sArr(R, 6)
dArr(K, 5) = dArr(K, 2) + dArr(K, 3) - dArr(K, 4)
End If
End If
Next I
With Sheet3
If K Then
.Range("A5:E1000").ClearContents
.Range("A5").Resize(K, 5) = dArr
End If
End With
Set Dic = Nothing
End Sub
thì chỉ cần nhập mã vào kéo công thức xuống là được hết.
Tức là bạn muốn :
xem thử file
mình không hiểu rõ tồn khó nó tính thế nào nếu gom cả mảng của tất cả các tháng trước đó thì -_-
Tồn kho tính dễ mà, nhập xuất thì sumif trong giai đoạn đó, còn tồn đầu thì sumif nhỏ hơn giai đoạn đó lấy nhập -xuất là ra thôi, tính toán số thì không khó dùng sumif là được, sợ chỗ lấy mã số hàng hóa không trùng hơi nặng với dữ liệu nhiều thôi.mình không hiểu rõ tồn khó nó tính thế nào nếu gom cả mảng của tất cả các tháng trước đó thì -_-
chủ yếu là cảm thấy thiết kế không hợp ly.
với ý mình nói là bạn học VBA nhanh quá, chứ không đề cập đến tốc độ công thức
!!
thì đấy tính tổng trước tháng chọnTồn kho tính dễ mà, nhập xuất thì sumif trong giai đoạn đó, còn tồn đầu thì sumif nhỏ hơn giai đoạn đó lấy nhập -xuất là ra thôi, tính toán số thì không khó dùng sumif là được, sợ chỗ lấy mã số hàng hóa không trùng hơi nặng với dữ liệu nhiều thôi.
Bài náy thiết kế gom 1 bảng thì thuận tiện cho VBA hơn, chứ công thức vẫn vậy.
VBA chỉ biết hơi hơi thôi,
gán giá trị 0 cho các ô trống, dùng format dạng số
Sub tonghop()
Dim InArr(), OutArr(), Arr(), i As Long, ik As Long, k As Long
Dim Dic As Object, Tmp
Dim Thang As Long, Nam As Long
With Sheets("Xem")
Thang = .Range("B2").Value
Nam = .Range("D2").Value
End With
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Nhap")
InArr = .Range("A3", .Range("F65535").End(3)).Value2
End With
With Sheets("Xuat")
OutArr = .Range("A3", .Range("F65535").End(3)).Value2
End With
ReDim Arr(1 To UBound(InArr) + UBound(OutArr), 1 To 5)
For i = 1 To UBound(InArr)
If (Month(InArr(i, 1)) <= Thang And Year(InArr(i, 1)) = Nam) Or Year(InArr(i, 1)) < Nam Then
Tmp = InArr(i, 5)
If Not Dic.exists(Tmp) Then
k = k + 1
Dic.Add Tmp, k
Arr(k, 1) = Tmp: Arr(k, 2) = 0
Arr(k, 3) = 0: Arr(k, 4) = 0
End If
ik = Dic(Tmp)
If Month(InArr(i, 1)) = Thang And Year(InArr(i, 1)) = Nam Then
Arr(ik, 3) = Arr(ik, 3) + InArr(i, 6)
Arr(ik, 5) = Arr(ik, 5) + InArr(i, 6)
End If
If (Month(InArr(i, 1)) < Thang And Year(InArr(i, 1)) = Nam) Or Year(InArr(i, 1)) < Nam Then
Arr(ik, 2) = Arr(ik, 2) + InArr(i, 6)
Arr(ik, 5) = Arr(ik, 5) + InArr(i, 6)
End If
End If
Next i
For i = 1 To UBound(OutArr)
If (Month(OutArr(i, 1)) <= Thang And Year(OutArr(i, 1)) = Nam) Or Year(OutArr(i, 1)) < Nam Then
Tmp = OutArr(i, 5)
If Not Dic.exists(Tmp) Then
k = k + 1
Dic.Add Tmp, k
Arr(k, 1) = Tmp: Arr(k, 2) = 0
Arr(k, 3) = 0: Arr(k, 4) = 0
End If
ik = Dic(Tmp)
If Month(OutArr(i, 1)) = Thang And Year(OutArr(i, 1)) = Nam Then
Arr(ik, 4) = Arr(ik, 4) + OutArr(i, 6)
Arr(ik, 5) = Arr(ik, 5) - OutArr(i, 6)
End If
If (Month(OutArr(i, 1)) < Thang And Year(OutArr(i, 1)) = Nam) Or Year(OutArr(i, 1)) < Nam Then
Arr(ik, 2) = Arr(ik, 2) - OutArr(i, 6)
Arr(ik, 5) = Arr(ik, 5) - OutArr(i, 6)
End If
End If
Next i
With Sheets("Xem")
.Range("A5:E1000").Clear
If k Then
.Range("A5").Resize(k, 5) = Arr
.Range("B5").Resize(k, 4).NumberFormat = " #,##0.00 ; [red](#,##0.00) ; - "
.Range("A5").Resize(k, 5).Borders.LineStyle = 1
End If
End With
Set Dic = Nothing
End Sub
Anh Hiếu cho em hỏi tí, Anh hay dùng mấy hàm này Tarr(), Darr(), Sarr(), vậy mấy hàm này có ý nghĩa gì vậy Anh? Anh có thể nêu ví dụ minh họa được không?
Code ai người ấy sửa nhé.
Public Sub BC_Thang()
Dim Dic As Object, sArr(), dArr(1 To 1000, 1 To 8), I As Long, J As Long, K As Long, R As Long, Rws As Long, NgayDau As Long, NgayCuoi As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("BCThang")
NgayDau = DateSerial(.Range("G2"), .Range("E2"), 1)
NgayCuoi = DateSerial(.Range("G2"), .Range("E2") + 1, 0)
End With
With Sheets("Nhap")
sArr = .Range("A3", .Range("A3").End(xlDown)).Resize(, 6).Value
R = UBound(sArr)
For I = 1 To R
Tem = sArr(I, 3) 'sArr(I, 5)'
If Not Dic.Exists(Tem) Then
K = K + 1: Dic.Add Tem, K
dArr(K, 1) = K: dArr(K, 2) = sArr(I, 3): dArr(K, 3) = sArr(I, 4): dArr(K, 4) = sArr(I, 5)
End If
Rws = Dic.Item(Tem)
If sArr(I, 1) < NgayDau Then
dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 6)
ElseIf sArr(I, 1) <= NgayCuoi Then
dArr(Rws, 6) = dArr(Rws, 6) + sArr(I, 6)
End If
Next I
End With
With Sheets("Xuat")
sArr = .Range("A3", .Range("A3").End(xlDown)).Resize(, 6).Value
R = UBound(sArr)
For I = 1 To R
Tem = sArr(I, 3) 'sArr(I, 5)'
If Not Dic.Exists(Tem) Then
K = K + 1: Dic.Add Tem, K
dArr(K, 1) = K: dArr(K, 2) = sArr(I, 3): dArr(K, 3) = sArr(I, 4): dArr(K, 4) = sArr(I, 5)
End If
Rws = Dic.Item(Tem)
If sArr(I, 1) < NgayDau Then
dArr(Rws, 5) = dArr(Rws, 5) - sArr(I, 6)
ElseIf sArr(I, 1) <= NgayCuoi Then
dArr(Rws, 7) = dArr(Rws, 7) + sArr(I, 6)
End If
Next I
End With
For I = 1 To K
dArr(I, 8) = dArr(I, 5) + dArr(I, 6) - dArr(I, 7)
Next I
With Sheets("BCThang")
.Range("A5:H1000").ClearContents
.Range("A5:H5").Resize(K) = dArr
End With
End SubTem = sArr(I, 3) '---------> sArr(I, 5)
Chỉnh lại code Xem
Sub tonghop()
Dim InArr(), OutArr(), Maso(), Arr() As Double, i As Long, ik As Long, k As Long
Dim Dic As Object, Tmp
Dim Thang As Long, Nam As Long
With Sheets("Xem")
Thang = .Range("B2").Value
Nam = .Range("D2").Value
End With
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Nhap")
InArr = .Range("A3", .Range("F65535").End(3)).Value2
End With
With Sheets("Xuat")
OutArr = .Range("A3", .Range("F65535").End(3)).Value2
End With
ReDim Maso(1 To UBound(InArr) + UBound(OutArr), 1 To 1)
ReDim Arr(1 To UBound(InArr) + UBound(OutArr), 1 To 4)
For i = 1 To UBound(InArr)
Tmp = InArr(i, 5)
If Not Dic.exists(Tmp) Then
k = k + 1: Dic.Add Tmp, k: Maso(k, 1) = Tmp
End If
ik = Dic(Tmp)
If Month(InArr(i, 1)) = Thang And Year(InArr(i, 1)) = Nam Then
Arr(ik, 2) = Arr(ik, 2) + InArr(i, 6)
ElseIf (Month(InArr(i, 1)) < Thang And Year(InArr(i, 1)) = Nam) Or Year(InArr(i, 1)) < Nam Then
Arr(ik, 1) = Arr(ik, 1) + InArr(i, 6)
End If
Next i
For i = 1 To UBound(OutArr)
Tmp = OutArr(i, 5)
If Not Dic.exists(Tmp) Then
k = k + 1: Dic.Add Tmp, k: Maso(k, 1) = Tmp
End If
ik = Dic(Tmp)
If Month(OutArr(i, 1)) = Thang And Year(OutArr(i, 1)) = Nam Then
Arr(ik, 3) = Arr(ik, 3) + OutArr(i, 6)
ElseIf (Month(OutArr(i, 1)) < Thang And Year(OutArr(i, 1)) = Nam) Or Year(OutArr(i, 1)) < Nam Then
Arr(ik, 1) = Arr(ik, 1) - OutArr(i, 6)
End If
Next i
For i = 1 To k
Arr(i, 4) = Arr(i, 1) + Arr(i, 2) - Arr(i, 3)
Next i
With Sheets("Xem")
.Range("A5:E1000").Clear
If k Then
.Range("A5").Resize(k, 1) = Maso
.Range("B5").Resize(k, 4) = Arr
.Range("B5").Resize(k, 4).NumberFormat = " #,##0.00 ; [red](#,##0.00) ; - "
.Range("A5").Resize(k, 5).Borders.LineStyle = 1
.Range("A4").Resize(k + 1, 5).Sort [A4], 1, Header:=xlYes 'sort theo Ma so
End If
End With
Set Dic = Nothing
End Subcòn code mới của anh chổ nào mà có dấu gạch ngang vậy Anh??
mình tách mảng kết quả thành 2 mảng:
Chạy code sheet Xem
Sub tonghop()
Dim Sarr, StoreArr(), Darr(), Maso(), Arr() As Double, i As Long, ik As Long, k As Long
Dim Dic As Object, Tmp
Dim NgayTon As Long, NgayDau As Long, NgayCuoi As Long
With Sheets("Xem")
NgayDau = DateSerial(.Range("D2"), .Range("B2"), 1)
NgayCuoi = DateSerial(.Range("D2"), .Range("B2") + 1, 0)
End With
i = Sheets("Nhap").UsedRange.Rows.Count + Sheets("Xuat").UsedRange.Rows.Count
ReDim Maso(1 To i, 1 To 1)
ReDim Arr(1 To i, 1 To 4)
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Tondau")
NgayTon = .Range("D1").Value2
StoreArr = .Range("C3", .Range("D" & Rows.Count).End(3)).Value2
End With
For i = 1 To UBound(StoreArr)
Tmp = StoreArr(i, 1)
If Not Dic.exists(Tmp) Then
k = k + 1: Dic.Add Tmp, k: Maso(k, 1) = Tmp
End If
ik = Dic(Tmp)
Arr(ik, 1) = Arr(ik, 1) + StoreArr(i, 2)
Next i
Sarr = Array("Nhap", "Xuat", 1, -1)
For s = 0 To 1
With Sheets(Sarr(s))
Darr = .Range("A3", .Range("F" & Rows.Count).End(3)).Value2
End With
For i = 1 To UBound(Darr)
Tmp = Darr(i, 5)
If Not Dic.exists(Tmp) Then
k = k + 1: Dic.Add Tmp, k: Maso(k, 1) = Tmp
End If
ik = Dic(Tmp)
If Darr(i, 1) < NgayDau And Darr(i, 1) >= NgayTon Then
Arr(ik, 1) = Arr(ik, 1) + Darr(i, 6) * Sarr(s + 2)
ElseIf Darr(i, 1) >= NgayDau And Darr(i, 1) <= NgayCuoi Then
Arr(ik, 2 + s) = Arr(ik, 2 + s) + Darr(i, 6)
End If
Next i
Next s
For i = 1 To k
Arr(i, 4) = Arr(i, 1) + Arr(i, 2) - Arr(i, 3)
Next i
With Sheets("Xem")
.Range("A5:E1000").Clear
If k Then
.Range("A5").Resize(k, 1) = Maso
.Range("B5").Resize(k, 4) = Arr
.Range("B5").Resize(k, 4).NumberFormat = " #,##0.00 ; [red](#,##0.00) ; - "
.Range("A5").Resize(k, 5).Borders.LineStyle = 1
.Range("A4").Resize(k + 1, 5).Sort [A4], 1, Header:=xlYes 'sort theo Ma so
End If
End With
Set Dic = Nothing
End Sub
bạn chỉnh lại code
Private Sub ChiTietCreat()
Dim Tarr As Variant, Arr As Variant, i As Long, K As Long
Dim Nhap As String, Xuat As String, Ton As Double, dk As String
If IsEmpty(Narr) Then CreatData
dk = Range("C5").Value
Nhap = [E8]
Xuat = [F8]
ReDim Arr(1 To UBound(Narr) + UBound(Xarr), 1 To 5)
With Sheets("Tondau")
Tarr = .Range("A3", .Range("D" & Rows.Count).End(3)).Value
End With
For i = 1 To UBound(Tarr)
If dk = Tarr(i, 1) Then
Ton = Tarr(i, 4): Exit For
End If
Next i
For i = 1 To UBound(Narr)
If dk = Narr(i, 3) Then
K = K + 1
Arr(K, 1) = Narr(i, 1): Arr(K, 3) = Narr(i, 1)
Arr(K, 2) = nh & " - " & "(" & Narr(i, 2) & ")": Arr(K, 4) = Narr(i, 6)
End If
Next i
For i = 1 To UBound(Xarr)
If dk = Xarr(i, 3) Then
K = K + 1
Arr(K, 1) = Xarr(i, 1): Arr(K, 3) = Xarr(i, 1)
Arr(K, 2) = xu & " - " & "(" & Xarr(i, 2) & ")": Arr(K, 5) = Xarr(i, 6)
End If
Next i
Range("A9:G" & 1000).Borders.LineStyle = 0
Range("A9:G" & 1000).ClearContents
If K Then
Range("B9").Resize(K, 5) = Arr
Range("B9:F9").Resize(K).Sort [B9], 1, [E9], , 2, Header:=xlNo
Range("A9").Value = 1
Range("A9").Resize(K).DataSeries
Range("A9:G9").Resize(K).Borders.LineStyle = 1
Range("B9").Resize(K).NumberFormat = "dd/mm/yyyy"
Range("D9").Resize(K).NumberFormat = "dd/mm/yyyy"
Range("E9").Resize(K, 3).NumberFormat = "#,##0.00 ;[red]( #,##0.00 )"
Range("G6").Value = Ton
Range("G9").Value = Ton + Range("E9").Value - Range("F9").Value
If K > 1 Then
For i = 10 To 8 + K
Range("G" & i) = Range("G" & i - 1) + Range("E" & i) - Range("F" & i)
Next i
End If
End If
End Sub
