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.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
Bạn dùng code sau, còn phần mã DV thì bạn nghiên cứu thử.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à
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
Chỉ có dùng Vlookup theo sh DM là ra MaDV thôi.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.
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
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2