làm sao dùng code VB để ra kết quả của công thức ConcSep_Array

[dotrung]

Tôi có 1 file theo dõi hóa đơn, nhưng do dùng công thức mảng ConcSep_Array nên rất chậm và dễ bị xóa. Tôi muốn kết quả hiện lên cell còn công thức sẽ chạy trong code VB. rất mong các cao thủ chỉ giúp, cảm ơn

 

[ThuNghi]

do file quá lớn, mình phải bỏ bớt dữ liệu rồi mới up lên được, mong các bạn chỉ giúp,ok

Những đơn vị không có nhận hóa đơn thì có cần đưa vào báo cáo với kết quả là rỗng? Hay là chỉ đưa những dv có nhận hoá đơn thôi.

 

[dotrung]

vâng, kết qủa đơn vị không nhận hóa đơn thì để rỗng, mình chủ yếu dùng mail megre trong word để in bao thư mà

 

[ThuNghi]

vâng, kết qủa đơn vị không nhận hóa đơn thì để rỗng, mình chủ yếu dùng mail megre trong word để in bao thư mà

Bạn dùng code sau, còn phần mã DV thì bạn nghiên cứu thử.

Option Explicit
Dim Dic As Object, sTmp As String
Dim endR As Long, i As Long, s As Long, k As Long
Dim Arr01, Arr02, Arr03, Arr
Dim iDate As Long
Sub TaoBaoCao()
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr01 = .Range("B3:B" & endR) 'Ngay
  Arr02 = .Range("C3:C" & endR) 'SoHD
  Arr03 = .Range("E3:E" & endR) 'DonVi
  iDate = .[J1]
End With
s = 0: ReDim Arr(1 To UBound(Arr01), 1 To 2)
For i = 1 To UBound(Arr01)
  If Arr01(i, 1) = iDate Then
    sTmp = Arr03(i, 1)
    If Not Dic.Exists(sTmp) Then
      s = s + 1
      Dic.Add sTmp, s
      Arr(s, 1) = sTmp
    End If
    k = Dic.Item(sTmp)
    If Len(Arr(k, 2)) = 0 Then
      Arr(k, 2) = Arr02(i, 1)
    Else
      Arr(k, 2) = Arr(k, 2) & "; " & Arr02(i, 1)
    End If
  End If
Next i
If s = 0 Then Exit Sub
Sheets("Data").Select
With Range("J3")
  .Resize(1000, 2).ClearContents
  .Resize(s, 2) = Arr
End With
Erase Arr01, Arr02, Arr: Set Dic = Nothing
End Sub

 

[dotrung]

mã DV tôi nghiên cứu mãi cũng không làm được, nhờ a ThuNghi giúp đỡ, chân thành cảm ơn anh.

 

[ThuNghi]

mã DV tôi nghiên cứu mãi cũng không làm được, nhờ a ThuNghi giúp đỡ, chân thành cảm ơn anh.

Chỉ có dùng Vlookup theo sh DM là ra MaDV thôi.
Với lại bài này nên lấy tên DV theo MaDV ai lại lấy ngược vậy.
Còn nếu muốn vậy thì thay code sau nhé.

Option Explicit
Dim Dic1 As Object, Dic2 As Object, sTmp As String
Dim endR As Long, i As Long, s As Long, k As Long
Dim Arr01, Arr02, Arr03, Arr04, Arr
Dim iDate As Long
Sub TaoBaoCao()
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr01 = .Range("B3:B" & endR) 'Ngay
  Arr02 = .Range("C3:C" & endR) 'SoHD
  Arr03 = .Range("E3:E" & endR) 'DonVi
  iDate = .[J1]
End With
'Tao Dic2 tu sh DM
With Sheets("DM")
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr04 = .Range("A2:B" & endR) 'DM
End With
For i = 1 To UBound(Arr04)
  If Not Dic2.Exists(Arr04(i, 1)) Then
    Dic2.Add Arr04(i, 1), Arr04(i, 2)
  End If
Next i
s = 0: ReDim Arr(1 To UBound(Arr01), 1 To 3)
For i = 1 To UBound(Arr01)
  If Arr01(i, 1) = iDate Then
    sTmp = Arr03(i, 1)
    If Not Dic1.Exists(sTmp) Then
      s = s + 1
      Dic1.Add sTmp, s
      Arr(s, 2) = sTmp
      Arr(s, 1) = Dic2.Item(sTmp) 'MaDV
    End If
    k = Dic1.Item(sTmp)
    If Len(Arr(k, 3)) = 0 Then
      Arr(k, 3) = Arr02(i, 1)
    Else
      Arr(k, 3) = Arr(k, 3) & "; " & Arr02(i, 1)
    End If
  End If
Next i
If s = 0 Then Exit Sub
Sheets("Data").Select
With Range("I3")
  .Resize(1000, 2).ClearContents
  .Resize(s, 3) = Arr
End With
Erase Arr01, Arr02, Arr03, Arr03, Arr: Set Dic1 = Nothing:: Set Dic2 = Nothing
End Sub