Bài này quá lớn với những bạn mới học! Tuy nhiên, đọc file của bạn tôi thấy có cách bố trí dữ liệu xuất thế này:
Sub THop()
Dim Dic As Object, Cls As Range, tam1, tam2, i
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
i = 1
For Each Cls In .Range(.[D4], .[D65536].End(3))
If Not Dic.Exists(Cls.Value) Then
Dic.Add Cls.Value, Taochuoi(Cls)
End If
Next
tam1 = Dic.keys
tam2 = Dic.items
For i = 0 To Dic.Count - 1
.Cells(i + 7, "F") = tam1(i) & " ( " & tam2(i) & " )"
Next
End With
Set Dic = Nothing: Set Cls = Nothing
End Sub
'===============================================
Function Taochuoi(ByVal Dk As String) As String
Dim Ar(), i, tam
Dim rg1, rg2, Ir, ch
Ar = Array("Mon", "Tue", "Wed", "Fri", "Thu", "Sat", "Sun")
With Sheet1
Ir = .[D65536].End(3).Row
rg1 = .Name & "!" & .[C4].Resize(Ir - 3).Address
rg2 = .Name & "!" & .[D4].Resize(Ir - 3).Address
For i = 0 To 6
ch = "=SUMPRODUCT(--(" & rg2 & "=""" & Dk & """" & "),--(" & rg1 & "=""" & Ar(i) & """" & "))"
If Evaluate(ch) > 0 Then tam = tam & IIf(Len(tam) > 0, "-", "") & Ar(i)
Next
End With
Taochuoi = tam
End FunctionCách này chậm lắm anh à! Vì SUMPRODUCT với nhiều điều kiện thì cũng tương đương với vòng lập For thôi (em thử code của anh, nó treo máy luôn)
Thêm 1 cái Custom Format cho mấy cái số ấy thành chữ "X" hết là hoàn hảo
Public Sub MoMam()
Dim Vung As Range, d As Object, Cll As Range, K As Long, Mg(1 To 300000, 1 To 8), TG As Double, iNgay As Range
Set d = CreateObject("scripting.dictionary")
Set Vung = Range([f2], [f500000].End(xlUp))
Set iNgay = [m2:s2]
TG = Timer: K = 1
For Each Cll In Vung
If Not d.exists(Cll.Value) Then
d.Add Cll.Value, K
Mg(K, 1) = Cll.Value
Mg(K, Application.WorksheetFunction.Match(Cll.Offset(, -3), iNgay, 0) + 1) = "x"
K = K + 1
Else
Mg(d.Item(Cll.Value), Application.WorksheetFunction.Match(Cll.Offset(, -3), iNgay, 0) + 1) = "x"
End If
Next
[l3].Resize(K, 8) = Mg
MsgBox Timer - TG
End SubNguyên tắc để tăng tốc là thế này nè anh ơi:
Dim Clls as Range
For Each Clls in Range("C1:C50000")
......
NextDim tmpArr, i as Long
tmpArr = Range("C1:C50000").Value
For i = LBound(tmpArr, 1) to UBound(tmpArr,1)
......
NextPrivate Sub ConsolStr2(ByVal sArr1, ByVal sArr2, ByVal Target As Range)
Dim tArr1, tArr2, Arr(1 To 1000000, 1 To 8)
Dim wd As New Collection, wdArr, Dic1, Dic2
Dim i As Long, j As Long, n As Long, k As Long
Dim Tmp As String, Tmp1 As String, Tmp2 As String
tArr1 = sArr1: tArr2 = sArr2
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
wdArr = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
Set wd = New Collection
For k = 0 To 6
wd.Add CStr(k + 2), wdArr(k)
Next k
For i = LBound(tArr1, 1) To UBound(tArr1, 1)
For j = LBound(tArr1, 2) To UBound(tArr1, 2)
If tArr1(i, j) <> "" Then
Tmp1 = tArr1(i, j): Tmp2 = tArr2(i, j)
Tmp = Tmp1 & Tmp2
If Not Dic1.Exists(Tmp) Then
Dic1.Add Tmp, ""
If Not Dic2.Exists(Tmp1) Then
n = n + 1
Dic2.Add Tmp1, n
Arr(n, 1) = Tmp1
Arr(n, wd.Item(Tmp2)) = "X"
Else
Arr(Dic2.Item(Tmp1), wd.Item(Tmp2)) = "X"
End If
End If
End If
Next j
Next i
Target.Resize(n, 8).Value = Arr
End SubSub Main2()
Dim sArr1, sArr2, Target As Range, TG As Double
TG = Timer
sArr1 = Sheet1.Range("F2:F1000000").Value
sArr2 = Sheet1.Range("C2:C1000000").Value
Set Target = Sheet1.Range("L3")
Target.Resize(1000000, 8).Clear
ConsolStr2 sArr1, sArr2, Target
MsgBox Timer - TG
End SubPublic Sub LaiMo()
Dim Vung, d As Object, Cll As Range, K As Long, Mg(1 To 300000, 1 To 8), TG As Double, iNgay, I, J, Ngay, Vung2
Set d = CreateObject("scripting.dictionary")
Vung = Range([f2], [f500000].End(xlUp)).Value
Vung2 = Range([c2], [c500000].End(xlUp)).Value
iNgay = Array("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
TG = Timer: K = 1
For I = LBound(Vung, 1) To UBound(Vung, 1)
For J = 0 To 6
If iNgay(J) = Vung2(I, 1) Then Ngay = J + 2: Exit For
Next
If Not d.exists(Vung(I, 1)) Then
d.Add Vung(I, 1), K
Mg(K, 1) = Vung(I, 1)
Mg(K, Ngay) = "x"
K = K + 1
Else
Mg(d.Item(Vung(I, 1)), Ngay) = "x"
End If
Next
[l3].Resize(K, 8) = Mg
MsgBox Timer - TG
End SubAnh con cò "ăn cắp" thời gian nha ---> Lý ra dòng TG = Timer phải nằm ở trên cùng (dưới dòng khai báo biến)
Sub ConsolStr3()
Dim tArr1, tArr2, Arr(1 To 300000, 1 To 8), ScrCtr, Dic1, Dic2
Dim i As Long, j As Long, n As Long, K As Long, TG As Double
Dim Tmp As String, Tmp1 As String, Tmp2 As String
TG = Timer
tArr1 = Sheet1.Range("F2:F300000").Value
tArr2 = Sheet1.Range("C2:C300000").Value
Set ScrCtr = CreateObject("MSScriptControl.ScriptControl")
ScrCtr.Language = "VBScript"
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tArr1)
If tArr1(i, 1) <> "" Then
Tmp1 = tArr1(i, 1): Tmp2 = tArr2(i, 1): Tmp = Tmp1 & Tmp2
If Not Dic1.Exists(Tmp) Then
Dic1.Add Tmp, ""
If Not Dic2.Exists(Tmp1) Then
n = n + 1
Dic2.Add Tmp1, n
Arr(n, 1) = Tmp1
Arr(n, ScrCtr.Eval("vb" & Tmp2) + 1) = "X"
Else
Arr(Dic2.Item(Tmp1), ScrCtr.Eval("vb" & Tmp2) + 1) = "X"
End If
End If
End If
Next i
Sheet1.Range("L3").Resize(n, 8).Value = Arr
MsgBox Timer - TG
End SubBạn qua đây tham gia ý kiến nhé:
. Em ngâm cứu dựa trên nền tảng code của bác, em đã SORT và gộp lại được thứ rồi (ví dụ : "Mon,Fri,Sat,Sun" sẽ thành "2,6-8"). Tốc độ cũng nhanh chả kém nguyên bản code ban đầu của bác (dữ liệu 300ngàn dòng khi chạy code không thấy sự khác biệt khi em thêm code của em vào). Cám ơn bác nhiều lắm ạ ^^.
