Xin hỏi cách làm tăng tốc cho code sau?

[win-sun]

- Tính chính xác nhưng quá chậm, liệu có phải do dử liệu nhiều không hay còn cách nào nhanh hơn , nhờ các sư phụ chỉ giúp>
Option Explicit
Sub THXNT()
Dim HC As Long
Dim i As Long
Dim Ma As Range

Application.Calculation = xlCalculationManual
HC = S109.Range("C65500").End(xlUp).Row

S109.Select
Range("EA9:U9").EntireColumn.Hidden = False
S109.Range("A9:R" & HC + 1).ClearContents
S109.Range("A10:R" & HC + 2).Select
Call NLine

HC = S101.Range("A65000").End(xlUp).Row

S109.Range("B9:G" & HC + 7).Value = S101.Range("A2:F" & HC).Value
Range("H9:H" & HC + 7).FormulaR1C1 = "=SUMPRODUCT((DataNgay<R5C6)*((LEFT(DataLYDO,4)=""NHAP"")-(LEFT(DataLYDO,4)=""XUAT""))*(DataTEN=RC[-5])*(DataSL))+RC[-1]"
Range("I9:I" & HC + 7).FormulaR1C1 = "=SUMPRODUCT((DataNgay>=R5C6)*(DataNgay<=R5C9)*(DataLYDO=""NHAP MUA"")*(DataTEN=RC[-6])*(DataSL))"
Range("J9:J" & HC + 7).FormulaR1C1 = "=SUMPRODUCT((DataNgay>=R5C6)*(DataNgay<=R5C9)*(DataLYDO=""NHAP KHAC"")*(DataTEN=RC[-7])*(DataSL))"
Range("K9:K" & HC + 7).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
Range("L9:L" & HC + 7).FormulaR1C1 = "=SUMPRODUCT((DataNgay>=R5C6)*(DataNgay<=R5C9)*(DataLYDO=""XUAT SU DUNG"")*(DataTEN=RC[-9])*(DataSL))"
Range("M9:M" & HC + 7).FormulaR1C1 = "=SUMPRODUCT((DataNgay>=R5C6)*(DataNgay<=R5C9)*(DataLYDO=""XUAT KHAC"")*(DataTEN=RC[-10])*(DataSL))"
Range("N9:N" & HC + 7).FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
Range("O9:O" & HC + 7).FormulaR1C1 = "=RC[-7]+RC[-4]-RC[-1]"
Range("T9:T" & HC + 7).FormulaR1C1 = "=IF(SUM(RC[-12]:RC[-5])>0,1,"""")"

With S109.Range("B9:T" & HC + 7)
.Calculate
.Value = .Value
.Sort Key1:=Range("T9"), Order1:=xlAscending, Key2:=Range( _
"B9"), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
End With

i = S109.Range("T65000").End(xlUp).Row
If i < 10 Then i = 10
S109.Range("A" & i + 1 & ":T" & HC + 7).ClearContents
S109.Range("T1:T5000").ClearContents

With Range("A9:A" & i)
.FormulaR1C1 = "=ROW()-8"
.Calculate
.Value = .Value
End With
With Range("G" & i + 2 & ":O" & i + 2)
.FormulaR1C1 = "=SUM(R9C:R[-1]C)"
.Calculate
.Value = .Value
End With
Range("C" & i + 2) = "TONG CONG"
Range("G:G").EntireColumn.Hidden = True
S109.Range("A10:R" & i + 1).Select
Call YLine
S109.Range("A" & i + 2 & ":R" & i + 2).Select
Call YLineTC
Range("D5").Select
End Sub

 

[win-sun]

Buồn như con chuồn chuồn?? xem giúp em cái thầu ơi, thanks

 

[ndu96081631]

Buồn như con chuồn chuồn?? xem giúp em cái thầu ơi, thanks

Để làm được cái việc tăng tốc trong file của bạn thật chẳng dễ ăn đâu. Bạn dùng SUMPRODUCT thì cho dù có viết vào code thì đấy vẫn là SUMPRODUCT thôi, tốc độ là khuyết điểm lớn nhất của nó
Muốn tăng tốc toàn diện, bạn nhất định không được dùng bất cứ hàm nào. Mọi thứ phải được chuyển sang Array để tính toán, xong việc, gán toàn bộ mảng kết quả về bảng tính ---> Rất chua, chỉ có thể "ráng" mà viết nếu đây là sản phẩm của chính mình
Bạn có thể tham khảo bài toán tương tự tại đây:
http://www.giaiphapexcel.com/forum/...y-nhất-theo-2-cột-Scripting.Dictionary!/page3

 

[ThuNghi]

Buồn như con chuồn chuồn?? xem giúp em cái thầu ơi, thanks

Tôi làm thử theo Arr mà anh NDU đề nghị.
Phần sort, sott và format bạn làm tiếp.
Góp ý:
1/ Sao MaVT ở Data và Danhmuc khác nhau
2/ -> Bạn làm sumproduct theo tên
3/ Mặt hàng sau hình như âm "Khí acetylen"

Option Explicit
Dim HC As Long
Dim i As Long, k As Long, s As Long, iR As Long, nR As Long, nC As Long
Dim MaVT As String, sDG As String, fDate As Date, eDate As Date
Dim ArrData(), ArrKQ(), ArrDG()
Dim myRng As Range
Dim Dic As Object, DicDG As Object
Const ColNg = 1: Const ColDg = 2: Const ColMaVT = 4:: Const ColDV = 5: Const ColSl = 6
Sub TaoDic()
Set Dic = CreateObject("Scripting.Dictionary")
With S101
  HC = .Range("A65500").End(xlUp).Row
  ArrData = .Range("A3:F" & HC).Value
End With
ReDim ArrKQ(1 To UBound(ArrData), 1 To 15)
For i = 1 To UBound(ArrData)
  MaVT = Trim(ArrData(i, 2))
  If Not Dic.Exists(MaVT) Then
    Dic.Add MaVT, i
    For k = 2 To 7 'Tu MaHH -> ton dau nam
      ArrKQ(i, k) = ArrData(i, k - 1)
    Next k
    ArrKQ(i, 8) = ArrKQ(i, 7) 'Gan ton dau ky = dau nam
    'ArrKQ(i, 15) = ArrKQ(i, 7)
  End If
Next i
'Tao phan DicDG nham the ham Match
ArrDG = Array("NHAP MUA", "NHAP KHAC", "N", "XUAT SU DUNG", "XUAT KHAC", "X")
'TaoDic
Set DicDG = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(ArrDG)
  DicDG.Add ArrDG(i), i + 1
Next i
Erase ArrDG, ArrData
End Sub
Sub TongHopNXT()
Application.Calculation = xlCalculationManual
TaoDic
'lay so dau ky den First Day
With S109
  fDate = CVDate(.[F5]): eDate = CVDate(.[I5])
End With
With S104
  .AutoFilterMode = False
  HC = .Range("C65500").End(xlUp).Row
  ArrData = .Range("A2:F" & HC).Value
End With
For iR = 1 To UBound(ArrData)
  MaVT = Trim(ArrData(iR, ColMaVT))
  nR = Dic.Item(MaVT)
  ArrKQ(nR, 3) = MaVT
  ArrKQ(nR, 5) = ArrData(iR, ColDV)
  If CVDate(ArrData(iR, ColNg)) <= eDate Then
    'Phan ton dk
    If CVDate(ArrData(iR, ColNg)) < fDate Then
      Select Case Left(ArrData(iR, ColDg), 4)
        Case Is = "NHAP"
          ArrKQ(nR, 8) = ArrKQ(nR, 8) + ArrData(iR, ColSl)
        Case Is = "XUAT"
          ArrKQ(nR, 8) = ArrKQ(nR, 8) - ArrData(iR, ColSl)
      End Select
    'Phan PS
    Else
      sDG = Trim(ArrData(iR, ColDg))
      nC = DicDG.Item(sDG) + 8
      ArrKQ(nR, nC) = ArrKQ(nR, nC) + ArrData(iR, ColSl)
    End If
    'Phan Tong cong va Ton cuoi
    ArrKQ(nR, 11) = ArrKQ(nR, 9) + ArrKQ(nR, 10) 'Tong Nhap
    ArrKQ(nR, 14) = ArrKQ(nR, 12) + ArrKQ(nR, 13) 'Tong Xuat
    ArrKQ(nR, 15) = ArrKQ(nR, 8) + ArrKQ(nR, 11) - ArrKQ(nR, 14) 'Tong Ton
  End If
Next iR
For iR = 1 To Dic.Count
  'Gan so ton cuoi neu kg co ps
  If ArrKQ(iR, 11) = 0 And ArrKQ(iR, 14) = 0 Then
    ArrKQ(iR, 15) = ArrKQ(iR, 8)
  End If
Next iR
With S109
  .[A9].Resize(5000, 15).ClearContents
  .[A9].Resize(Dic.Count, 15) = ArrKQ
  .Range("C" & Dic.Count + 9) = "TONG CONG"
  With .Range("G" & Dic.Count + 9 & ":O" & Dic.Count + 9)
    .FormulaR1C1 = "=SUM(R9C:R[-1]C)"
    .Calculate
    .Value = .Value
  End With
  Set myRng = .Range("A9").Resize(Dic.Count, 15)
End With

Erase ArrKQ
Set Dic = Nothing: Set DicDG = Nothing
Set myRng = Nothing

Application.Calculation = xlCalculationAutomatic
End Sub

 

[ndu96081631]

Tôi làm thử theo Arr mà anh NDU đề nghị.
Phần sort, sott và format bạn làm tiếp.

Đã thử file, tốc độ cực.. "sốc" (mặc dù code như đám rừng....)
Cảm ơn ThuNghi! Bạn nhiệt tình quá. Nếu là mình chắc không kham nỗi. Chẳng phải là lười hoặc không có lòng nhưng có vài kiến thức về kế toán mình chẳng hiểu ti gì. Cứ mỗi lần nhìn thấy từ NHẬP, XUẤT, TỒN là mình muốn.. chạy rồi
Để xem tác giả down file về có ý kiến thế nào? Nếu là "OK" thì chắc phải khao ít nhất chầu cafe chứ nhỉ?
Ẹc... Ẹc...

 

[win-sun]

Tôi làm thử theo Arr mà anh NDU đề nghị.
Phần sort, sott và format bạn làm tiếp.
Góp ý:
1/ Sao MaVT ở Data và Danhmuc khác nhau
2/ -> Bạn làm sumproduct theo tên
3/ Mặt hàng sau hình như âm "Khí acetylen"
- Xin cảm ơn Thunghi đã rất nhiệt tình giúp đỡ. Đã đúng ý em rồi nhưng do code dài quá em phải ngâm cứu thêm nữa thì mới dám mạnh dạn sử dụng.
- Mã VT và danhmuc khác nhau là do em chỉ nhập gợi ý ở cột mã thôi chứ mã dài quá đâu có nhớ chính xác được.
- Chính vì vậy mà em chọn cái tên hàng để so sánh
- Mặt hàng âm là do dử liệu chưa đầy đủ.
- Hiện em cũng mài mò theo cách đơn giản hơn, số tồn kho em tính theo tháng cũng được, không cần phải từ ngày - đến ngày. add thêm pivotable điều khiển theo khi chọn tháng để lọc bớt dử liệu phát sinh rồi dùng sumif
- Chỉ còn cái em chưa làm được là tùy biến số dư đầu kỳ: khi chọn tháng ở sheet NXT thì ớ sh danhmuc sẽ chạy đến cột số dư đầu kỳ tương ứng. tại sh NXT em làm thêm cái macro khóa sổ cuối tháng nữa, khi khóa số code lọc số lượng tồn cuối tháng trước gán vào tồn đầu kỳ tháng sau tại sh danh muc. Rất mong các sư phụ giúp đỡ, thanks

 

[win-sun]

quên kẹp file
S109.Range("H9:H" & HC + 7).Value = S101.Range("F2:F" & HC).Value