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?
