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
