Bạn dùng thử code này xem sao:
Public Sub GomGom()
Dim Vung, d, I, K, Gom, A, M, mM, Tach, TachTiep, Kq
Set d = CreateObject("scripting.dictionary")
Vung = Range([D5], [D50000].End(xlUp)).Offset(, -2).Resize(, 5)
ReDim Kq(1 To UBound(Vung), 1 To 4)
For I = UBound(Vung) To 1 Step -1
If Vung(I, 1) = "" Then
Gom = Gom & Vung(I, 2) & ";" & Vung(I, 3) & ";" & Vung(I, 4) & ";" & Vung(I, 5) & ","
Else
If Not d.exists(Vung(I, 2)) Then
Gom = Vung(I, 2) & "," & Gom
d.Add Vung(I, 2), Gom
Gom = ""
Else
d.Item(Vung(I, 2)) = d.Item(Vung(I, 2)) & Gom
Gom = ""
End If
End If
Next I
A = d.items
For I = UBound(A) To 0 Step -1
Tach = Split(A(I), ",")
K = K + 1
Kq(K, 1) = Tach(0)
For M = UBound(Tach) - 1 To 1 Step -1
TachTiep = Split(Tach(M), ";")
K = K + 1
Kq(K, 2) = TachTiep(1): Kq(K, 3) = TachTiep(2): Kq(K, 4) = TachTiep(3)
Next M
Next I
Sheets("Ket qua").[G4].Resize(K, 4) = Kq
End Sub
Tham khảo thêm code này nhé
Sub TonghopDL()
Dim Arr(), ArrKQ(), iItem
Dim i As Long, j As Long, s As Long, m As Long, k As Long
Arr = Sheet1.Range("C5:F" & Sheet1.[D65000].End(3).Row + 1)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" And Not Dic.Exists(Arr(i, 1)) Then
Dic.Add Arr(i, 1), ""
End If
Next
ReDim ArrKQ(1 To UBound(Arr), 1 To UBound(Arr, 2))
For Each iItem In Dic.keys
s = s + 1
ArrKQ(s, 1) = iItem
For i = 1 To UBound(Arr)
If Arr(i, 1) = iItem Then
For m = i + 1 To i + 10
If Arr(m, 1) <> "" Or m = UBound(Arr) Then GoTo NextI
s = s + 1
For j = 2 To UBound(Arr, 2)
ArrKQ(s, j) = Arr(m, j)
Next
Next
End If
NextI:
Next
Next
Sheet2.Range("F4").Resize(s, UBound(Arr, 2)).Value = ArrKQ
End SubSub TongHopHoangTrongNghia()
Dim c As Long, h As Long, i As Long, j As Long
Dim k As Long, r As Long, t As Long
Dim sArray As Variant, HoTen As Variant
Dim DataArr1 As Variant, DataArr2 As Variant
Dim DataArray As Variant, Chk As Boolean
r = DuLieu.Range("D65536").End(xlUp).Row
sArray = DuLieu.Range("C5:F" & r).Value
i = UBound(sArray, 1): j = UBound(sArray, 2)
ReDim DataArr1(1 To i, 1 To 1): k = 0
With CreateObject("Scripting.Dictionary")
For h = 1 To i
HoTen = sArray(h, 1)
If Not .Exists(HoTen) And sArray(h, 1) <> "" Then
k = k + 1
.Add HoTen, k
DataArr1(k, 1) = HoTen
End If
Next
End With
ReDim DataArr2(1 To i, 1 To j)
For h = 1 To i
If h = 1 Then
DataArr2(h, 1) = sArray(h, 1)
Else
If sArray(h, 2) = "" Then
DataArr2(h, 1) = sArray(h, 1)
Else
DataArr2(h, 1) = DataArr2(h - 1, 1)
For c = 2 To j
DataArr2(h, c) = sArray(h, c)
Next
End If
End If
Next
ReDim DataArray(1 To i, 1 To j): r = 1
For t = 1 To k
Chk = True
HoTen = DataArr1(t, 1)
For h = 1 To i
If Chk Then
If DataArr2(h, 1) = HoTen And DataArr2(h, 2) = "" Then
DataArray(r, 1) = HoTen
r = r + 1
Chk = False
End If
Else
If DataArr2(h, 1) = HoTen And DataArr2(h, 2) <> "" Then
DataArray(r, 1) = ""
For c = 2 To j
DataArray(r, c) = DataArr2(h, c)
Next
r = r + 1
End If
End If
Next
Next
KetQua.Range("B:E").ClearContents
KetQua.Range("B4").Resize(r, j) = DataArray
End Sub
Dữ liệu có bằng nắm tay mà kiểm tra cái cóc khô gì!
Híc
Nói chứ viết cho chạy thôi, chứ kiểm tra tốc độ thi dữ liệu phải nhiều & ....nắn nót code lại chứ nhỉ
Sub Tonghop_quanghai()
Dim d As Object, kq(), dl()
Dim i As Long, j As Long, k As Long, x As Byte
Set d = CreateObject("scripting.dictionary")
With Sheets("Du lieu")
dl = .Range(.[c5], .[f65536].End(3)).Value
End With
ReDim kq(1 To UBound(dl), 1 To 5)
For i = 2 To UBound(dl)
If dl(i, 1) = "" Then dl(i, 1) = dl(i - 1, 1)
If Not d.Exists(dl(i, 1)) Then d.Add dl(i, 1), ""
Next
Key = d.keys
For i = 0 To UBound(Key)
k = k + 1
kq(k, 1) = i + 1: kq(k, 2) = Key(i)
For j = 1 To UBound(dl)
If dl(j, 1) = Key(i) Then
If dl(j, 2) <> "" Then
k = k + 1
For x = 3 To 5
kq(k, x) = dl(j, x - 1)
Next
End If
End If
Next
Next
Sheets("Du lieu").[H5].Resize(k, 5) = kq
End Sub
Option Base 1
Option Explicit
Sub test()
Dim arrDulieu(), arrKetqua(), DicHoTen, i, k, j, jj, ten
Set DicHoTen = CreateObject("Scripting.Dictionary")
Sheets("Du lieu").Select
arrDulieu = Sheets("Du lieu").Range([D5], [D65536].End(xlUp)).Offset(, -2).Resize(, 5).Value
ReDim arrKetqua(UBound(arrDulieu, 1), 5)
For i = 1 To UBound(arrDulieu, 1)
If arrDulieu(i, 1) > 0 Then
If Not DicHoTen.Exists(arrDulieu(i, 2)) Then
j = j + 1: k = k + 1: jj = j
DicHoTen.Add arrDulieu(i, 2), jj
arrKetqua(k, 2) = arrDulieu(i, 2)
End If
ten = arrDulieu(i, 2)
Else
k = k + 1
jj = DicHoTen.Item(ten)
arrKetqua(k, 3) = arrDulieu(i, 3)
arrKetqua(k, 4) = arrDulieu(i, 4)
arrKetqua(k, 5) = arrDulieu(i, 5)
End If
arrKetqua(k, 1) = jj
Next
Sheets("Ket qua").Select
With Range("A23")
.Resize(k, 5).Value = arrKetqua
.Resize(k, 5).Sort Range("A23"), 1
.Resize(k).ClearContents
End With
End Sub
Sub TongHopHoangTrongNghiaNew()
Dim tg As Double: tg = Timer
Dim sArray, DataArr, DataArray, FullName, MyDic As Object, _
c As Long, h As Long, i As Long, j As Long, k As Long, n As Long, r As Long, t As Long, _
OutCheck As Boolean, InCheck As Boolean
KetQua.Range("A:E").ClearContents
sArray = DuLieu.Range("C5:F" & DuLieu.Range("D65536").End(xlUp).Row + 1).Value
i = UBound(sArray, 1): j = UBound(sArray, 2)
Set MyDic = CreateObject("Scripting.Dictionary")
For h = 1 To i
FullName = sArray(h, 1)
If Not MyDic.Exists(FullName) And FullName <> "" Then MyDic.Add FullName, ""
Next
ReDim DataArray(1 To i, 1 To j + 1): r = 1: n = 0
FullName = MyDic.keys
For t = 0 To UBound(MyDic.keys)
OutCheck = True
For h = 1 To i
If h = i - 1 Then Exit For
k = h + 1
If sArray(h, 1) = FullName(t) And sArray(k, 1) = "" Then
If OutCheck Then
n = n + 1
DataArray(r, 1) = n
DataArray(r, 2) = FullName(t)
OutCheck = False: r = r + 1
End If
InCheck = True
End If
If InCheck And sArray(k, 1) = "" Then
For c = 3 To j + 1
DataArray(r, c) = sArray(k, c - 1)
Next
r = r + 1
Else
InCheck = False
End If
Next
Next
KetQua.Range("A4").Resize(r - 1, j + 1) = DataArray
KetQua.Range("K65536").End(xlUp).Offset(1).Value = "Nghia / " & Format(Timer - tg, "0.00000000")
'Debug.Print "Nghia / " & Format(Timer - tg, "0.00000000")
End SubKhông đúng, mình lặp lại vòng lệnh For.. next:
For m = i + 1 To i + 10
If Arr(m, 1) <> "" Or m = UBound(Arr) Then GoTo NextI
s = s + 1
For j = 2 To UBound(Arr, 2)
ArrKQ(s, j) = Arr(m, j
Next
End If
NextToàn là các ĐẠI CA xuất chiêu hết cả rồi, em làm sao có cơ hội đây?
Sub Tonghop()
Dim Arr, sArr
Dim dic As Object
Dim i, k, t As Integer
Arr = Sheet1.Range("C5:F" & Sheet1.[D65000].End(3).Row)
Set dic = CreateObject("Scripting.Dictionary")
ReDim sArr(1 To UBound(Arr, 1), 1 To 4)
' Gan item vao Dic
With dic
For i = 1 To UBound(Arr, 1)
If Not .exists(Arr(i, 1)) And Arr(i, 1) <> "" Then
k = k + 1
.Add Arr(i, 1), k
ElseIf .exists(Arr(i, 1)) Then
Arr(i, 2) = 1
End If
Next
End With
' thay the cot c = " " sang gia tri ben tren
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = "" Then
Arr(i, 1) = Arr(i - 1, 1)
End If
Next
' trich loc
For Each Item In dic.keys
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = Item And Arr(i, 2) <> 1 Then
t = t + 1
sArr(t, 1) = Arr(i, 1)
sArr(t, 2) = Arr(i, 2)
sArr(t, 3) = Arr(i, 3)
sArr(t, 4) = Arr(i, 4)
End If
Next
Next
Sheet2.[f4].Resize(UBound(Arr, 1), 4) = sArr
End SubSub Tonghop()
Dim Arr, sArr
Dim dic As Object
Dim i, k, t As Integer
Arr = Sheet1.Range("C5:F" & Sheet1.[D65000].End(3).Row)
Set dic = CreateObject("Scripting.Dictionary")
ReDim sArr(1 To UBound(Arr, 1), 1 To 4)
' Gan item vao Dic
With dic
For i = 1 To UBound(Arr, 1)
If Not .exists(Arr(i, 1)) And Arr(i, 1) <> "" Then
k = k + 1
.Add Arr(i, 1), k
ElseIf .exists(Arr(i, 1)) Then
Arr(i, 2) = 1
End If
Next
End With
' thay the cot c = " " sang gia tri ben tren
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = "" Then
Arr(i, 1) = Arr(i - 1, 1)
End If
Next
'--- trich Loc
For Each Item In dic.keys
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = Item And Arr(i, 2) = "" Then
t = t + 1
sArr(t, 1) = Arr(i, 1)
ElseIf Arr(i, 1) = Item And Arr(i, 2) <> 1 Then
t = t + 1
sArr(t, 2) = Arr(i, 2)
sArr(t, 3) = Arr(i, 3)
sArr(t, 4) = Arr(i, 4)
End If
Next
Next
Sheet2.[f4].Resize(UBound(Arr, 1), 4) = sArr
End SubDạ mảng bắt đầu từ "Cà Văn Bó" với ô D5 = "" như vậy khi thay thế giá trị "" dưới "Cà Văn Bó"....bằng "Cà Văn Bó" mới được, như vậy code trên không sai, nếu sai khi và chỉ khi không tồn tại "Cà Văn Bó" đầu tiên (cái này có thể bắt lỗi)
[COLOR=#ff0000]Sheets("Du lieu").Select[/COLOR]
arrDulieu = Sheets("Du lieu").Range([D5], [D65536].End(xlUp)).Offset(, -2).Resize(, 5).Value [COLOR=#ff0000]Sheets("Ket qua").Select[/COLOR]
With Range("A4")
.Resize(k, 5).Value = arrKetqua
.Resize(k, 5).Sort Range("A4"), 1
.Resize(k).ClearContents
End WitharrDulieu = Range([COLOR=#0000ff]Sheets("Du lieu")[/COLOR].[D5], [COLOR=#0000ff]Sheets("Du lieu")[/COLOR].[D65536].End(xlUp)).Offset(, -2).Resize(, 5).Value With Sheets("Ket qua").Range("A4")
.Resize(k, 5).Value = arrKetqua
.Resize(k, 5).Sort Range("A4"), 1
.Resize(k).ClearContents
End With' thay the cot c = " " sang gia tri ben tren
For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = "" Then
Arr(i, 1) = Arr(i - 1, 1)
End If
NextFor i = [COLOR=#ff0000][B]2[/B][/COLOR] To UBound(Arr, 1)
If Arr(i, 1) = "" Then
Arr(i, 1) = Arr(i - 1, 1)
End If
NextMình giải thế này, xử lý tại vùng dữ liệu gốc luôn. Tuy có hơi chậm hơn cách có dictionary nhưng cũng không nhiều lắm
Sub Tonghop_No_Dic()
Dim dl(), i As Long, kq(), j As Long, k As Long, n As Long
With Sheets("Du lieu")
dl = .Range(.[C5], .[D65536].End(3).Offset(, 2)).Value
For i = 2 To UBound(dl)
If dl(i, 1) = "" Then dl(i, 1) = dl(i - 1, 1)
Next
.[C5].Resize(UBound(dl), 4) = dl
.Range(.[C5], .[D65536].End(3).Offset(, 2)).Sort key1:=.[C3]
dl = .Range(.[C5], .[D65536].End(3).Offset(, 2)).Value
For i = UBound(dl) To 2 Step -1
If dl(i, 1) = dl(i - 1, 1) Then dl(i, 1) = Empty
Next
.[C5].Resize(UBound(dl), 4) = dl
ReDim kq(1 To UBound(dl), 1 To 5)
For i = 1 To UBound(dl)
If dl(i, 1) <> "" Or dl(i, 2) <> "" Then
k = k + 1
If dl(i, 2) = "" Then
n = n + 1: kq(k, 1) = n
End If
For j = 2 To 5
kq(k, j) = dl(i, j - 1)
Next
End If
Next
.[B5].Resize(UBound(dl), 5) = kq
End With
End SubCái này chỉ là thói quen thôi (mình thống nhất với ... mình vậy rồi), để đề phòng bất trắc xảy ra, vì trong module của mình nhiều khi không phải là một mảng mà có thể nhiều mảng nên trên đầu module nào có mảng mình luôn dể câu Option Base 1. Vì vậy, có khi trước một mảng mình khai báo là ReDim arrABC(1 To 10, 1 To 5) nhưng trên đầu module của mình vẫn có câu Option Base 1 do quên không xóa nhưng vô hại.
Nếu muốn có STT thì có nhiều cách, nhưng làm sao không phải thêm vòng lặp nữa để khổi ảnh hưởng tốc độ. Không gì khó cả, đã có vòng lặp sẵn rồi, tạo thêm một mảng một cột lấy STT đồng thời với việc tạo mảng kết quả khi chạy vòng lặp đó. Có mảng TT rồi, khi gán mảng kết quả và sort xong ta gán mảng này luôn. Mình thích thuật toán này vì chỉ dùng có một vòng lăp cho cả sub.
Ờ, cũng là do thói quen thôi, khi code ít di chuyển qua lại giữa các Sheet thì mình luôn làm vậy để dùng cho các câu lệnh khác luôn, ở đây chỉ có hai lần chọn Sheet nên mình nghĩ là không sao.
Private Sub Worksheet_Activate()
End Sub
Private Sub Worksheet_Deactivate()
End SubVậy là như thế nào anh Nghĩa, nếu tác động trục tiếp trên cell thì vẫn có cách trích lọc duy nhất mà.
Sub Th()
Dim Arr, Dl
Dim i, k As Integer
With Sheet1
Dl = .Range("c5:f" & [f65536].End(xlUp).Row)
ReDim Arr(1 To UBound(Dl), 1 To 4)
For i = 1 To [f65536].End(xlUp).Row
If Cells(i + 2, 3) <> "" And Application.WorksheetFunction.CountIf(Range(Cells(5, 3), Cells(i + 2, 3)), Cells(i + 2, 3)) = 1 Then
k = k + 1
Arr(k, 1) = Cells(i + 2, 3)
End If
Next
End With
End SubHíc, cái này hình như không chính xác lắm, lúc trước chưa biết sử dụng em "Đít To" thì cũng có cả đống cách giải quyết duy nhất cơ mà
Sub HTN_UniqueOnly_Sort()
Dim h As Long, i As Long, r As Long
Dim sArray, UnqArr, sItem As String
With Sheet1.Range("BB1:BB60")
.Value = Sheet1.Range("A1:A60").Value
.Sort Sheet1.[BB1], 1
sArray = .Value
.Clear
End With
i = UBound(sArray, 1): r = 0: sItem = ""
ReDim UnqArr(1 To i, 1 To 1)
For h = 1 To i
If sArray(h, 1) <> "" And sArray(h, 1) <> sItem Then
r = r + 1
UnqArr(r, 1) = sArray(h, 1)
End If
sItem = sArray(h, 1)
Next
Sheet1.Range("J3").Resize(r).Value = UnqArr
End SubSub loc_khong_trung_quanghai()
Dim dl(), tim As Object, i As Long
dl = Range([A1], [a65536].End(3)).Value
For i = 1 To UBound(dl)
Set tim = Range("J:J").Find(dl(i, 1))
If tim Is Nothing Then [J65536].End(3).Offset(1) = dl(i, 1)
Next
End SubPublic Sub DuyNhat()
Dim Vung, Kq, Cll, Tach
Vung = Range([A1], [A10000].End(xlUp))
For Each Cll In Vung
If Cll <> "" Then
If InStr(1, Kq, Cll) = 0 Then Kq = Kq & Cll & ","
End If
Next Cll
Tach = Split(Kq, ",")
[B1].Resize(UBound(Tach)) = Application.WorksheetFunction.Transpose(Tach)
End Sub
Sub Test()
Dim Tm, Kq()
Tm = Sheet1.[A1:A60]
ReDim Kq(1)
For i = 1 To UBound(Tm, 1)
If InStr(1, Join(Kq, ";"), Tm(i, 1)) = 0 Then
Kq(UBound(Kq) - 1) = Tm(i, 1)
ReDim Preserve Kq(UBound(Kq) + 1)
End If
Next
Sheet1.[j3].Resize(UBound(Kq) + 1) = _
WorksheetFunction.Transpose(Kq)
End SubHihi, sửa tí _ cái này bị hoài mà chẳng nhớ. Híc
Public Sub DuyNhat()
Dim Vung, Kq, Cll, Tach
Vung = Range([A1], [A10000].End(xlUp))
For Each Cll In Vung
If Cll <> "" Then
If InStr(1, Kq, Cll & ",") = 0 Then Kq = Kq & Cll & ","
End If
Next Cll
Tach = Split(Kq, ",")
[B1].Resize(UBound(Tach)) = Application.WorksheetFunction.Transpose(Tach)
End SubPublic Sub DuyNhat()
Dim Vung, Kq, Cll, Tach, KetQua, i As Long
Vung = Range([A1], [A10000].End(xlUp))
For Each Cll In Vung
If Cll <> "" Then
If InStr(1, Kq, Cll & ",") = 0 Then Kq = Kq & Cll & ","
End If
Next Cll
Tach = Split(Kq, ",")
ReDim KetQua(1 To UBound(Tach), 1 To 1)
For i = 1 To UBound(Tach)
KetQua(i, 1) = Tach(i - 1)
Next
[B1].Resize(UBound(Tach)) = KetQua
End SubSub duynhat()
Dim arr, sarr
Dim i, j, k As Integer
arr = Range([A1], [A10000].End(xlUp))
ReDim sarr(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr)
For j = i + 1 To UBound(arr)
If arr(j, 1) = arr(i, 1) Then
arr(j, 1) = ""
End If
Next
Next
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then
k = k + 1
sarr(k, 1) = arr(i, 1)
End If
Next
[B1].Resize(UBound(sarr)) = sarr
End SubCode này sẽ chạy rất chậm nếu xử lý dữ liệu nhiều, nếu dữ liệu 20 000 dòng thì tức là 20 000 X 20 000 = 400 000 000
Option Base 1
Sub Test_noDic()
Dim tg As Double: tg = Timer
Dim arrDulieu(), arrKetqua(), i, k, j, jj, arrOnly(), x, kt, TT
arrDulieu = Range(Sheets("Du lieu").[J5], Sheets("Du lieu").[J65536].End(xlUp)).Offset(, -2).Resize(, 5).Value
ReDim arrKetqua(UBound(arrDulieu, 1), 5)
For i = 1 To UBound(arrDulieu, 1)
If arrDulieu(i, 2) <> "" Then
kt = 0
If k > 1 Then
For x = 1 To UBound(arrOnly, 2)
If arrDulieu(i, 2) = arrOnly(2, x) Then kt = 1: TT = arrOnly(1, x)
Next
End If
If kt = 0 Then 'ten chua co trong danh sach
j = j + 1: k = k + 1: jj = j
ReDim Preserve arrOnly(1 To 2, jj)
arrOnly(1, jj) = jj: arrOnly(2, jj) = arrDulieu(i, 2)
arrKetqua(k, 2) = arrDulieu(i, 2)
End If
Else
k = k + 1
If kt = 1 Then jj = TT
arrKetqua(k, 3) = arrDulieu(i, 3)
arrKetqua(k, 4) = arrDulieu(i, 4)
arrKetqua(k, 5) = arrDulieu(i, 5)
End If
arrKetqua(k, 1) = jj
Next
With Sheets("Ket qua").Range("A4")
.Resize(k, 5).Value = arrKetqua
.Resize(k, 5).Sort Sheets("Ket qua").Range("A4"), 1
End With
Dim arrTT()
arrTT = Sheets("Ket qua").Range("A4").Resize(k, 2).Value
For i = 1 To UBound(arrTT, 1)
If arrTT(i, 2) = "" Then arrTT(i, 1) = ""
Next
Sheets("Ket qua").Range("A4").Resize(k, 2).Value = arrTT
MsgBox Format(Timer - tg, "0.00000000")
End SubMá ơi, đã tạo mảng gán kết quả thì ......gán luôn lúc phát hiện cell nào là duy nhất, sao lại phải thêm vòng lặp chi nữa
Public Sub DuyNhat()
Dim Vung, Kq, Cll, Mg, K
Vung = Range([A1], [A10000].End(xlUp))
ReDim Mg(1 To UBound(Vung), 1 To 1)
For Each Cll In Vung
If Cll <> "" Then
If InStr(1, Kq, Cll & ",") = 0 Then
K = K + 1
Kq = Kq & Cll & ","
Mg(K, 1) = Cll
End If
End If
Next Cll
[B1].Resize(K) = Mg
End SubSub Test()
Dim Kt As Boolean, Tm, Kq(), i, j
Tm = Sheet1.[A1:A60]
ReDim Kq(1)
For i = 1 To UBound(Tm, 1)
Kt = True
For j = 0 To UBound(Kq)
If Tm(i, 1) = Kq(j) Then
Kt = False: Exit For
End If
Next
If Kt Then
Kq(UBound(Kq) - 1) = Tm(i, 1)
ReDim Preserve Kq(UBound(Kq) + 1)
End If
Next
Sheet1.[j3].Resize(UBound(Kq) + 1) = _
WorksheetFunction.Transpose(Kq)
End Sub
