Nhờ các thầy chuyển giúp từ công thức sang code VBA (2 người xem)

ninhtom1 · 12/6/12

Em nhờ các thầy, anh chị trên diễn đàn chuyển giúp hộ em từ công thức sang code VBA với ạ. Trong file em dùng hàm Vookup, hàm Sumproduct nên file chạy rất chậm. Công thức ở bên Sheet BAOCAO đấy ạ.

ThuNghi · 12/6/12

ninhtom1 đã viết:
Em nhờ các thầy, anh chị trên diễn đàn chuyển giúp hộ em từ công thức sang code VBA với ạ. Trong file em dùng hàm Vookup, hàm Sumproduct nên file chạy rất chậm. Công thức ở bên Sheet BAOCAO đấy ạ.

Bạn có thể cụ thể thêm
1/ SH Baocao chỉ lấy dữ liệu từ sh Xuat? Nếu vậy thì đơn giản hơn trong lấy DM.
2/ Z9 và AB9 sh Baocao sao kg là PX ĐS mà là NĐS. Nếu là PX ĐS thì cũng kg cần dùng dòng 7
Đã sửa Z9 và AB9.

PHP:

Sub TaoBC()
Dim endR&, i&, s&, k&, nR&, nC&
Dim fDate&, eDate&
Dim sTmp01$, sTmp02$
Dim Arr, ArrPX, ArrDM, ArrSL
Dim Dic01 As Object, Dic02 As Object
Set Dic01 = CreateObject("Scripting.Dictionary")
Set Dic02 = CreateObject("Scripting.Dictionary")
With Sheets("BaoCao")
  fDate = CLng(.[J4])
  eDate = CLng(.[L4])
  ArrPX = .Range("F9:AB9").Value
End With
With Sheets("Xuat")
  endR = .Cells(65000, "E").End(3).Row
  Arr = .Range("D6:N" & endR).Value
End With
s = 0
For i = 1 To UBound(ArrPX, 2) Step 2
  sTmp01 = Trim(Mid(ArrPX(1, i), 4, 10))
  s = s + 1
  Dic01.Add sTmp01, s
Next i
ReDim ArrDM(1 To 10000, 1 To 5)
ReDim ArrSL(1 To 10000, 1 To 24)
s = 0
For i = 1 To UBound(Arr)
  If CLng(Arr(i, 1)) <= eDate Then
    If CLng(Arr(i, 1)) >= fDate Then
      If Len(Arr(i, 2)) > 0 Then
        sTmp02 = Arr(i, 2)
        sTmp01 = Arr(i, 8)
        If Not Dic02.Exists(sTmp02) Then
          s = s + 1
          Dic02.Add sTmp02, s
          ArrDM(s, 1) = s 'TT
          For k = 2 To 4
            ArrDM(s, k) = Arr(i, k)
          Next k
        End If
        nR = Dic02.Item(sTmp02)
        nC = 2 * Dic01.Item(sTmp01) - 1
        ArrSL(nR, nC) = ArrSL(nR, nC) + Arr(i, 5)
        ArrSL(nR, nC + 1) = ArrSL(nR, nC + 1) + Arr(i, 7)
        ArrDM(nR, 5) = ArrDM(nR, 5) + Arr(i, 5)
      End If
    End If
  End If
Next i
If s Then
  With Sheets("BaoCao")
    .[A11].Resize(1000, 29).ClearContents
    .[A11].Resize(s, 5) = ArrDM
    .[F11].Resize(s, 24) = ArrSL
  End With
  Erase ArrDM, ArrSL
End If
Set Dic01 = Nothing: Set Dic02 = Nothing
Erase Arr, ArrPX

End Sub

ninhtom1 · 13/6/12

Cảm ơn thầy ạ. Đúng là BAOCAO em chỉ lấy dữ liệu bên Sheet Xuat thôi. Nhưng tên vật tư em muốn lấy bên Sheet CDNXT vì bên Xuat cũng là vật tư đó nhưng em có thể chú thích thêm vào tên của nó.
VD:AU001 là Ấu nối xích máng cào SKAt 80 nhưng khi xuất em lại ghi chú cho nó thêm là Ấu nối xích máng cào SKAt 80 (DV-25) chẳng hạn. Em sợ như thế thì không lấy đc tên vật tư theo Sheet Xuat.
Thầy có thể dịch code sang tiếng việt giúp em được không ạ. Cảm ơn thầy nhiều.

ThuNghi · 13/6/12

ninhtom1 đã viết:
Cảm ơn thầy ạ. Đúng là BAOCAO em chỉ lấy dữ liệu bên Sheet Xuat thôi. Nhưng tên vật tư em muốn lấy bên Sheet CDNXT vì bên Xuat cũng là vật tư đó nhưng em có thể chú thích thêm vào tên của nó.
VD:AU001 là Ấu nối xích máng cào SKAt 80 nhưng khi xuất em lại ghi chú cho nó thêm là Ấu nối xích máng cào SKAt 80 (DV-25) chẳng hạn. Em sợ như thế thì không lấy đc tên vật tư theo Sheet Xuat.
Thầy có thể dịch code sang tiếng việt giúp em được không ạ. Cảm ơn thầy nhiều.

Vấn đề chính là file trên đúng yêu cầu chưa?
Phần lấy tên VT theo sh XNT thì tạm thời dùng Vlookup.
Thú thật, diễn giải code theo tiếng Việt thì xin lỗi vì văn phong hơi khiêm tốn và viết code thì OK nhưng dịch lại thì chả biết cách nào.
Nôm na code trên có 2 Dic với nhiệm vụ:
- Dic01 lấy danh mục theo dòng 9 (tiêu đề sh BaoCao.
- Dic02 lấy MaVT
Trong code có biến nR và nC.
- nR là dòng xuất hiện Mavt (Dic02.Item)
- nC là cột để gán kết quả (Dic01.Item), lưu ý là 2 * nC -1 là mỗi tiêu thì sẽ lấy thành 2 cột.
Nghiên cứu chút xíu về Dictionary là bạn sẽ hiểu. Tôi tin là bạn làm được qua những gì bạn đã vận dụng.
Chúc thành công.

ninhtom1 · 13/6/12

Vâng file trên đúng yêu cầu rồi ạ. Em hỏi thêm chút nữa là bên Sheet Xuat nếu có 1 vật tư nào chưa vào mã ĐV Lĩnh (cột K) thì sẽ bị báo lỗi. Giờ bên BAOAO em xóa hết các cột Nợ Phiếu đi thì code phải sửa thế nào ạ. Nhờ thầy chỉ giúp.
Cái hàm UBound(Arr) này là hàm gì ấy ạ.

ThuNghi · 13/6/12

ninhtom1 đã viết:
Vâng file trên đúng yêu cầu rồi ạ. Em hỏi thêm chút nữa là bên

Sheet Xuat nếu có 1 vật tư nào chưa vào mã ĐV Lĩnh (cột K) thì sẽ bị báo lỗi. Giờ bên BAOAO em xóa hết các cột Nợ Phiếu đi thì code phải sửa thế nào ạ. Nhờ thầy chỉ giúp.
Cái hàm UBound(Arr) này là hàm gì ấy ạ.

A/ Nếu chưa có cột K thì báo lỗi, cần thì viết thêm 1 dòng code

PHP:

If Not Dic01.Exists(sTmp01) Then
          MsgBox "Chua nhap " & sTmp01 & " tai cot K dong " & i + 5
          Exit Sub
        End If

B/ Phần bạn sửa chưa đúng
1-

PHP:

For i = 1 To UBound(ArrPX, 2)  Step 2

th

PHP:

For i = 1 To UBound(ArrPX, 2)

Nhớ số 2 vì ArPX là mảng 1 chiều. Và bỏ Step 2 vì mình chỉ lấy theo từng 1 cột.

2-

PHP:

nC = 2 * Dic01.Item(sTmp01) - 1

thành

PHP:

nC = Dic01.Item(sTmp01)

Lúc này nC (cột) chỉ lấy 1.
3-

PHP:

.[F11].Resize(s, 24) = ArrSL

thành

PHP:

.[F11].Resize(s, 12) = ArrSL

Và code

PHP:

Sub TaoBC()
Dim endR&, i&, s&, k&, nR&, nC&
Dim fDate&, eDate&
Dim sTmp01$, sTmp02$
Dim Arr, ArrPX, ArrDM, ArrSL
Dim Dic01 As Object, Dic02 As Object
Set Dic01 = CreateObject("Scripting.Dictionary")
Set Dic02 = CreateObject("Scripting.Dictionary")
With Sheets("BaoCao")
  fDate = CLng(.[J4])
  eDate = CLng(.[L4])
  ArrPX = .Range("F9:Q9").Value
End With
With Sheets("Xuat")
  endR = .Cells(65000, "E").End(3).Row
  Arr = .Range("D6:N" & endR).Value
End With
s = 0
 'For i = 1 To UBound(ArrPX, 2)  Step 2'
 For i = 1 To UBound(ArrPX, 2)
  sTmp01 = Trim(Mid(ArrPX(1, i), 4, 10))
  s = s + 1
  Dic01.Add sTmp01, s
Next i
ReDim ArrDM(1 To 10000, 1 To 5)
ReDim ArrSL(1 To 10000, 1 To 12)
s = 0
For i = 1 To UBound(Arr)
  If CLng(Arr(i, 1)) <= eDate Then
    If CLng(Arr(i, 1)) >= fDate Then
      If Len(Arr(i, 2)) > 0 Then
        sTmp02 = Arr(i, 2)
        sTmp01 = Arr(i, 8)
         If Not Dic01.Exists(sTmp01) Then
          MsgBox "Chua nhap " & sTmp01 & " tai cot K dong " & i + 5
          Exit Sub
        End If
        If Not Dic02.Exists(sTmp02) Then
          s = s + 1
          Dic02.Add sTmp02, s
           ArrDM(s, 1) = s 'TT'
          For k = 2 To 4
            ArrDM(s, k) = Arr(i, k)
          Next k
        End If
        nR = Dic02.Item(sTmp02)
        nC = Dic01.Item(sTmp01)
         'nC = 2 * Dic01.Item(sTmp01) - 1'
        ArrSL(nR, nC) = ArrSL(nR, nC) + Arr(i, 5)
        ' ArrSL(nR, nC + 1) = ArrSL(nR, nC + 1) + Arr(i, 7)'
        ArrDM(nR, 5) = ArrDM(nR, 5) + Arr(i, 5)
      End If
    End If
  End If
Next i
If s Then
  With Sheets("BaoCao")
    .[A11].Resize(1000, 29).ClearContents
    .[A11].Resize(s, 5) = ArrDM
     '.[F11].Resize(s, 24) = ArrSL'
    .[F11].Resize(s, 12) = ArrSL
  End With
  Erase ArrDM, ArrSL
End If
Set Dic01 = Nothing: Set Dic02 = Nothing
Erase Arr, ArrPX

End Sub

ninhtom1 · 13/6/12

Vâng chính xác, còn cái vụ "Sheet Xuat nếu có 1 vật tư nào chưa vào mã ĐV Lĩnh (cột K) thì sẽ bị báo lỗi". Ý của em là nếu chưa có Mã ĐVL thì bỏ qua không cộng dòng đó. Chỉ cộng tổng những dòng nào có mã ĐVL thôi.

ThuNghi · 13/6/12

ninhtom1 đã viết:
Vâng chính xác, còn cái vụ "Sheet Xuat nếu có 1 vật tư nào chưa vào mã ĐV Lĩnh (cột K) thì sẽ bị báo lỗi". Ý của em là nếu chưa có Mã ĐVL thì bỏ qua không cộng dòng đó. Chỉ cộng tổng những dòng nào có mã ĐVL thôi.

PHP:

If Not Dic01.Exists(sTmp01) Then
          MsgBox "Chua nhap " & sTmp01 & " tai cot K dong " & i + 5
          Exit Sub
        End If

Bạn để ý phần if này, ie nếu ... thì msg and exit sub.
Vậy bạn sẽ thay như sau

PHP:

If Not Dic01.Exists(sTmp01) Then Goto Next_For

Và thêm câu này vào trên câu next i
Next_For:
next i

ie nếu kg tìm thấy sTmp01 trong Dic01 thì thực thi next i.

ninhtom1 · 13/6/12

Vâng. Cảm ơn thầy rất nhiều

ninhtom1 · 13/6/12

Thầy ThuNghi ơi cho em làm phiền thầy chút nữa. Giờ em có tình huống phức tạp hơn trước nhờ thầy giúp đỡ. Yêu cầu cũng tựa như trên là tính tổng theo mã vật tư nhưng không lọc theo mã ĐL Lĩnh nữa mà lọc theo mã Xe, máy bên cột Mục đích của Sheet Xuat. Làm sao có thể lọc chính xác số xe, máy ra? Nhờ thầy giúp đỡ.

ThuNghi · 14/6/12

S/c bảo dưỡng 2cụm sàng 150T/h+250T/h

ninhtom1 đã viết:
Thầy ThuNghi ơi cho em làm phiền thầy chút nữa. Giờ em có tình huống phức tạp hơn trước nhờ thầy giúp đỡ. Yêu cầu cũng tựa như trên là tính tổng theo mã vật tư nhưng không lọc theo mã ĐL Lĩnh nữa mà lọc theo mã Xe, máy bên cột Mục đích của Sheet Xuat. Làm sao có thể lọc chính xác số xe, máy ra? Nhờ thầy giúp đỡ.

Nến có thêm 1 danh mục để nhận biết. Vì cột mục đích không nhất quán về vị tr1i xuất hiện xe máy. Nếu không thì sh xuat nên thêm cột Xe máy theo mực đích.
Vd:
- Máy PC 300 - Xúc than + đất đá V13 thì lấy vào cột PC
- Xe 14N 0245 - V/c đất đá V13 thì lấy 14N-0245.
- S/ c bảo dưỡng ... thì lấy cái gì. Có cái gì phân biệt.
Quan trọng là dòng 9 sh BC phải đúng chính tả với số xe máy.
Nội khoảng trắng và dấu - là 1 vấn đề.

Làm như vậy để tránh thêm nhiều vòng for i không cần thiết.
Cố gắng đi, xây dựng CSDL nên chuẩn 1 chút thì sẽ easy cho report. Yêu cầu này kg khó, cũng như yêu cầu 1, chỉ là lấy dm duy nhất là cột khác.

ninhtom1 · 14/6/12

Vâng bên Sheet Xuat em có Cột Mã Xe-Máy (cột S) chính là tên xe, máy em đã lọc ra đó. Có thể lọc theo Cột S cũng đc. Nhưng em muốn lọc từ cột Mục đích (cột N) cho chính xác. Vì khi xuất đôi khi còn chèn dòng mà lại quên copy công thức từ dòng trên xuống thì cột S(mã xe, máy) không lọc ra được tên xe, máy.
- Những hàng nào mà không có xe, máy thì không thuộc xe, máy (không cần báo cáo)

ThuNghi · 14/6/12

ninhtom1 đã viết:
Vâng bên Sheet Xuat em có Cột Mã Xe-Máy (cột S) chính là tên xe, máy em đã lọc ra đó. Có thể lọc theo Cột S cũng đc. Nhưng em muốn lọc từ cột Mục đích (cột N) cho chính xác. Vì khi xuất đôi khi còn chèn dòng mà lại quên copy công thức từ dòng trên xuống thì cột S(mã xe, máy) không lọc ra được tên xe, máy.
- Những hàng nào mà không có xe, máy thì không thuộc xe, máy (không cần báo cáo)

Dung code sau

PHP:

Dim myStr$, Str$
Dim ArrXM()
Dim Obj As Object
Public Function LocArr(sTmp As String, sArr) As String
Set Obj = CreateObject("VBScript.RegExp")
For i = 1 To UBound(sArr)
  If Len(ArrXM(i, 1)) > 0 Then
    If Len(myStr) = 0 Then
      myStr = sArr(i, 1)
    Else
      myStr = myStr & "|" & sArr(i, 1)
    End If
  End If
Next i
With Obj
  .Global = True
  .IgnoreCase = True
  .Pattern = myStr
  If .Test(sTmp) Then
    myStr = .Execute(sTmp)(0)
  Else
    myStr = ""
  End If
End With
LocArr = myStr
End Function
Public Function IsArrayEmtpy(Mang As Variant) As Boolean
On Error GoTo XulyError
    Dim i As Integer
    i = UBound(Mang)
    IsArrayEmtpy = False
    Exit Function
XulyError:
    IsArrayEmtpy = True
End Function
Sub TaoArr()
With Sheets("Xemay")
  ArrXM = .Range("C6:C100").Value
End With
End Sub
Sub TaoBC()
With Application
  .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Dim endR&, i&, s&, k&, nR&, nC&
Dim fDate&, eDate&
Dim sTmp01$, sTmp02$
Dim Arr, ArrPX, ArrDM, ArrSL
Dim Dic01 As Object, Dic02 As Object
Set Dic01 = CreateObject("Scripting.Dictionary")
Set Dic02 = CreateObject("Scripting.Dictionary")
With Sheets("BaoCao")
  fDate = CLng(.[J4])
  eDate = CLng(.[L4])
  ArrTd = .Range("F9:BP9").Value
End With
If IsArrayEmtpy(ArrXM) Then
  TaoArr
End If
s = 0
For i = 1 To UBound(ArrTd, 2)
  Str = ArrTd(1, i)
  sTmp01 = LocArr(Str, ArrXM)
  If Len(sTmp01) = 0 Then sTmp01 = i
  s = s + 1
  Dic01.Add sTmp01, s
Next i
With Sheets("Xuat")
  endR = .Cells(65000, "E").End(3).Row
  Arr = .Range("D6:N" & endR).Value
End With
ReDim ArrDM(1 To 10000, 1 To 5)
ReDim ArrSL(1 To 10000, 1 To 63)
s = 0
For i = 1 To UBound(Arr)
  If CLng(Arr(i, 1)) <= eDate Then
    If CLng(Arr(i, 1)) >= fDate Then
      If Len(Arr(i, 2)) > 0 Then
        Str = Arr(i, 11)
        sTmp01 = LocArr(Str, ArrXM)
        If Len(sTmp01) > 0 Then
          sTmp02 = Arr(i, 2)
          If Not Dic02.Exists(sTmp02) Then
            s = s + 1
            Dic02.Add sTmp02, s
            ArrDM(s, 1) = s 'TT'
            For k = 2 To 4
              ArrDM(s, k) = Arr(i, k)
            Next k
          End If
          nR = Dic02.Item(sTmp02)
          nC = Dic01.Item(sTmp01)
          ArrSL(nR, nC) = ArrSL(nR, nC) + Arr(i, 5)
          ArrDM(nR, 5) = ArrDM(nR, 5) + Arr(i, 5)
        End If
      End If
    End If
  End If
Next i
If s Then
  With Sheets("BaoCao")
    .[A11].Resize(1000, 68).ClearContents
    .[A11].Resize(s, 5) = ArrDM
    .[F11].Resize(s, 63) = ArrSL
  End With
  Erase ArrDM, ArrSL
End If
Set Dic01 = Nothing: Set Dic02 = Nothing
Erase Arr, ArrTd
With Application
  .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub

ninhtom1 · 14/6/12

Thú thực là đọc code em không hiểu được. Thầy có thể chỉnh hộ sao cho từ F9:BZ9 để em có thể gõ số xe trực tiếp vào đó (0245, 0146, 7949, PC, TS,....) được không. Vì sau này xe, máy có thể có thêm nữa. Cảm ơn thầy nhiều

ThuNghi · 15/6/12

ninhtom1 đã viết:
Thú thực là đọc code em không hiểu được. Thầy có thể chỉnh hộ sao cho từ F9:BZ9 để em có thể gõ số xe trực tiếp vào đó (0245, 0146, 7949, PC, TS,....) được không. Vì sau này xe, máy có thể có thêm nữa. Cảm ơn thầy nhiều

Tôi thấy bạn viết UDF Loc rất cáo siêu mà sao kg chịu nghiên cứu code.
Vấn đề là code trên có OK?.
Còn vấn đề F9:BZ9 thì đơn giản thôi.
1/ Khai biến eC (cột cuối cùng)
2/ Xác định ArrTD lại
Cụ thể như sau:

PHP:

With Sheets("BaoCao")
  fDate = CLng(.[J4])
  eDate = CLng(.[L4])
  eC = .Cells(9, 6).End(xlToRight).Column
  ArrTd = .Cells(9, 6).Resize(, eC - 5).Value
  'ArrTd = .Range("F9:BP9").Value'
End With

Code trên tôi làm mà kg cần dùng kq từ hàm Loc của S (Mã Xe máy).
Ham Loc trên là nguyên do chậm máy. Code trên tôi cũng vận dụng hàm đó, sẽ nghiên cứu giản đơn hơn cho nhanh. Vì chỉ cần lấy MyStr 1 lần đầu.
Đề xuất như sau:
Từ sh Xuat theo cột 11 - Mục đích, nếu có mục đích nào phù hợp với C6:C100 sh XeMay thì mới lấy sang sh BaoCao, như vậy sẽ bò thêm 1 vòng xác định số xe duy nhất.
Hy vọng bạn sẽ nắm bắt.

ninhtom1 · 15/6/12

Thì đúng là có hàm lọc vào đâm ra file em chạy như rùa bò. Thí có nhiều chỗ đọc vẫn chưa hiểu thật mà. Cảm ơn thầy rất nhiều. Code bài trên thì rất OK rồi, em chỉ lăn tăn vụ thêm xe, máy thôi. Để em thử thêm đoạn code này vào đã. Hì hì.

ninhtom1 · 15/6/12

Xin lỗi làm phiền thầy 1 lần này nữa thôi. Giờ em tạo thêm 1 Sheet TONGHOP nữa để tổng hợp số lượng theo đơn vị lĩnh. Đơn vị vừa là số vừa là chữ lại lẫn lộn không theo quy định nào. Nhờ thầy sửa giúp code tính tổng theo Mã VT và Mã ĐV lĩnh với.

ThuNghi · 16/6/12

ninhtom1 đã viết:
Xin lỗi làm phiền thầy 1 lần này nữa thôi. Giờ em tạo thêm 1 Sheet TONGHOP nữa để tổng hợp số lượng theo đơn vị lĩnh. Đơn vị vừa là số vừa là chữ lại lẫn lộn không theo quy định nào. Nhờ thầy sửa giúp code tính tổng theo Mã VT và Mã ĐV lĩnh với.

Bài này cũng giống như bài file NXT, bạn vận dụng vào, thay tên sh BaoCao -> TongHop.

Ba Tê · 16/6/12

ninhtom1 đã viết:
Xin lỗi làm phiền thầy 1 lần này nữa thôi. Giờ em tạo thêm 1 Sheet TONGHOP nữa để tổng hợp số lượng theo đơn vị lĩnh. Đơn vị vừa là số vừa là chữ lại lẫn lộn không theo quy định nào. Nhờ thầy sửa giúp code tính tổng theo Mã VT và Mã ĐV lĩnh với.

Tham gia 1 code cho vui, vừa học hỏi mấy cái "Đic Đic lộn xộn".
Code dùng cho sheet TongHop.

PHP:

Public Sub GPE1()
Dim Rng(), Rng1(), Arr(), I As Long, K As Long, Dic As Object, Dic1 As Object, ND As Long, NC As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic1 = CreateObject("Scripting.Dictionary")
    Rng = Sheets("Xuat").Range(Sheets("Xuat").[D6], Sheets("Xuat").[D65000].End(xlUp)).Resize(, 8).Value
    Rng1 = Sheets("Tonghop").Range(Sheets("Tonghop").[F10], Sheets("Tonghop").[F10].End(xlToRight)).Value
    ND = Sheets("Tonghop").[J4].Value: NC = Sheets("Tonghop").[L4].Value
ReDim Arr(1 To UBound(Rng, 1), 1 To UBound(Rng1, 2) + 5)
    For I = 1 To UBound(Rng1, 2)
        Dic1.Add Rng1(1, I), I
    Next I
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 2) <> "" Then
            If Not Dic.exists(Rng(I, 2)) Then
                K = K + 1
                Dic.Add Rng(I, 2), K
                Arr(K, 1) = K: Arr(K, 2) = Rng(I, 2)
                Arr(K, 3) = Rng(I, 3): Arr(K, 4) = Rng(I, 4)
                    If Rng(I, 1) >= ND And Rng(I, 1) <= NC Then
                        Arr(K, Dic1.Item(Rng(I, 8)) + 5) = Rng(I, 5)
                        Arr(K, 5) = Arr(K, 5) + Rng(I, 5)
                    End If
            Else
                If Rng(I, 1) >= ND And Rng(I, 1) <= NC Then
                    Arr(Dic.Item(Rng(I, 2)), Dic1.Item(Rng(I, 8)) + 5) = Arr(Dic.Item(Rng(I, 2)), Dic1.Item(Rng(I, 8)) + 5) + Rng(I, 5)
                    Arr(Dic.Item(Rng(I, 2)), 5) = Arr(Dic.Item(Rng(I, 2)), 5) + Rng(I, 5)
                End If
            End If
        End If
    Next I
        Sheets("Tonghop").[A11:A1000].Resize(, UBound(Rng1, 2) + 5).ClearContents
            Sheets("Tonghop").[A11].Resize(K, UBound(Rng1, 2) + 5).Value = Arr
Set Dic = Nothing
Set Dic1 = Nothing
End Sub

Kiểm tra số liệu thấy sai, tìm cả buổi trời rồi tức muốn "hộc máu".
VD:dòng 1348 mã " MĐ" (có khoảng trắng phía trước).Híc!
Dữ liệu vài chục ngàn dòng mà nhập kiểu này "thất thoát tài sản" chết luôn.

ThuNghi · 17/6/12

Ba Tê đã viết:
Tham gia 1 code cho vui, vừa học hỏi mấy cái "Đic Đic lộn xộn".
Code dùng cho sheet TongHop.

PHP:

For I = 1 To UBound(Rng1, 2) Dic1.Add Rng1(1, I), I Next I For I = 1 To UBound(Rng, 1) If Rng(I, 2) <> "" Then If Not Dic.exists(Rng(I, 2)) Then K = K + 1 Dic.Add Rng(I, 2), K Arr(K, 1) = K: Arr(K, 2) = Rng(I, 2) Arr(K, 3) = Rng(I, 3): Arr(K, 4) = Rng(I, 4) If Rng(I, 1) >= ND And Rng(I, 1) <= NC Then Arr(K, Dic1.Item(Rng(I, 8)) + 5) = Rng(I, 5) Arr(K, 5) = Arr(K, 5) + Rng(I, 5) End If Else If Rng(I, 1) >= ND And Rng(I, 1) <= NC Then Arr(Dic.Item(Rng(I, 2)), Dic1.Item(Rng(I, 8)) + 5) = Arr(Dic.Item(Rng(I, 2)), Dic1.Item(Rng(I, 8)) + 5) + Rng(I, 5) Arr(Dic.Item(Rng(I, 2)), 5) = Arr(Dic.Item(Rng(I, 2)), 5) + Rng(I, 5) End If End If End If Next I

Kiểm tra số liệu thấy sai, tìm cả buổi trời rồi tức muốn "hộc máu".
VD:dòng 1348 mã " MĐ" (có khoảng trắng phía trước).Híc!
Dữ liệu vài chục ngàn dòng mà nhập kiểu này "thất thoát tài sản" chết luôn.

E xin tham gia như sau:
1/ Khi lấy Dic1 thì nên dùng thêm trim

PHP:

Dic1.Add Trim(Rng1(1, I)), I

2/ Và khi truy xuất cũng nên thêm Trim

PHP:

Arr(K, Dic1.Item(Trim(Rng(I, 8))) + 5) = Rng(I, 5)

Như vậy tránh sai sót chính tả về khoản trắng.
3/ E nghĩ là nên thêm biến NewC và NewR để xác định dòng và cột tìm thấy Item.

PHP:

NewC=Dic1.Item(Trim(Rng(I, 8)))
NeWR=Dic.Item(Rng(I, 2))

4/ Nếu ngày >= ND and <=NC.
- Phần này nên thay thành 2 If, nó sẽ chạy nhanh hơn.
- Và nên dùng dòng code dưới dòng

PHP:

If Rng(I, 2) <> "" Then
If Rng(I, 1) >= ND then
If Rng(I, 1) <= NC then
...

Điều này sẽ giảm 1 lần if.
E xin phép được chọt Bác Ba Tê 1 chút.

Nhờ các thầy chuyển giúp từ công thức sang code VBA (2 người xem)

Người dùng đang xem chủ đề này

Thành viên hoạt động

File đính kèm

Hãy cho rồi sẽ nhận!

File đính kèm

Thành viên hoạt động

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

File đính kèm

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Thành viên hoạt động

File đính kèm

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Thành viên hoạt động

File đính kèm

Hãy cho rồi sẽ nhận!

Cạo Rồi Khỏi Gội

File đính kèm

Hãy cho rồi sẽ nhận!

Đếm ngược thời gian