Hàm tự tạo đó bạn!
Bạn thử đưa 1 file gần giống với thực tế nhất lên đây (file có 300,000 dòng ấ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, Chuoi(Cls)
End If
Next
tam1 = Dic.keys
tam2 = Dic.items
For i = 0 To Dic.Count - 1
.Cells(i + 5, "H") = tam1(i) & " ( " & tam2(i) & " )"
Next
End With
Set Dic = Nothing : Set Cls = Nothing
End Sub
'===============================================
Function Chuoi(ByVal Ch As String) As String
Dim Rng As Range, Dc As String, tam As String
With Sheet1.Range("D4:D65536")
Set Rng = .Find(Ch, LookIn:=xlValues)
If Not Rng Is Nothing Then
Dc = Rng.Address
Do
If InStr(1, tam, Rng.Offset(, -1).Value) = 0 Then _
tam = IIf(Len(tam) > 0, tam & "-" & _
Rng.Offset(, -1).Value, Rng.Offset(, -1).Value)
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> Dc
End If
End With
Chuoi = tam
Set Rng = Nothing
End FunctionChèn 1 Module và paste code này vào:
Private Sub ConsolStr(ByVal sArr1, ByVal sArr2, ByVal Target As Range)
Dim tArr1, tArr2, Arr(1 To 1000000, 1 To 2), Tmp, Tmp1, Tmp2, Dic1, Dic2
Dim i As Long, j As Long, n As Long
tArr1 = sArr1: tArr2 = sArr2
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
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, 2) = Tmp2
Else
Arr(Dic2.Item(Tmp1), 2) = Arr(Dic2.Item(Tmp1), 2) & " - " & Tmp2
End If
End If
End If
Next j
Next i
Target.Resize(n, 2).Value = Arr
End SubSub Main()
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, 2).Clear
ConsolStr sArr1, sArr2, Target
MsgBox Timer - TG
End Sub
. Khi thấy kết quả chạy ra (rất nhanh + chính xác) em thấy nó hơi dài ạ. Bác có thể chỉ giúp em :
Riêng về việc lấy 3 ký tự của Weekday thì rất dễBác NDU quá siêu
1/ Nếu được, bác dành chút thời gian comment từng dòng code cho em hiểu được kô ạ ? Em cũng muốn học hỏi chút ít ^^? Nhìn vô như đám rừng, em đọc chả hiểu j cả. Cám ơn bác lần nữa ạ.
2/ Xin lỗi bác do em ghi chú trong file kô kĩ
- tương ứng từng dòng chương trình (ví dụ "chao buoi sang") sẽ là 1 dòng kết quả tổng hợp (chao buoi sang (Mon-Sun))
- Ngày chiếu chỉ lấy 3 kí tự đầu. Ví dụ : Monday thành Mon, Sunday thành Sun
- Ngày chiếu liệt kê sẽ rất dài. Có cách nào tổng hợp lại cho gọn. Ví dụ: Mon-Sun là chiếu từ T2 tới CN. Mon-Thu,Sun là chiếu từ T2 tới T5 và CN (thứ 6,7 kô chiếu)
Chi tiết xem file đính kèm giúp em ạ.
@ Có dịp offline nhất định gặp bác NDU để thỉnh giáo
, Cách2 theo yêu cầu của bác
..
Cũng khó chứ chẳng phải dễ ăn đâu ---> Chỉ nội xem trong chuổi Mon-Tue-Wed-Sun, làm sao biến nó thành Mon--->Web,Sun cũng rã rời rồi (vì phải sort chuổi, xem đoạn này "liên tục" thì lấy thằng đầu và cuối)Nếu có thời gian bác làm giúp em 2 cách luôn được không bác ? Cách1 theo đúng yêu cầu của em
Học tại đây là ngon lành rồi!À, bác có dạy thêm lập trình VBA không ạ ? Em đăng kí học riêng với bác được không ? Học vào ngày cuối tuần (thứ 7 hay CN đều được). Em hâm mộ bác quá
Nếu được nhắn tin cho em số điện thoại + tên của bác nhé. Số em đây : 0989.023530 - em tên HIỂN.
LÀM GÌ MÀ HỌC CHEN NGANG NHƯ VẬY ĐƯỢC
. Chỉ là không siêu như mấy bác NDU mà thôi --> học trực tiếp là hay nhất.
Tôi nghĩ lại thấy diễn đàn này cũng có rất nhiều bạn có nhu cầu học VBA như bạn! Vậy sao không tập trung lại chừng 20 người rồi mở lớp?Em cũng có căn bản rồi bác. Khôgn phải là không biết gì
Năn nỉ quá trời mà bác NDU vẫn không chịu thì em đành tự mò thôi vậy
20"), 2, 0)
Đại ca ơi! Vấn đề ở đây không phải nằm ở chổ có viết code được hay không mà là: PHẢI VIẾT ĐỂ CODE CHẠY VỚI DỮ LIỆU LỚN VÀ TỐC ĐỘ NHANH
File gốc đây
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 ạ ^^.
