Gộp dữ liệu từ nhiều vùng ? (2 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
TrungChinhs

TrungChinhs

Thành viên tích cực
Tham gia
18/2/08
Bài viết
1,475
Được thích
2,469
Nghề nghiệp
Công chức
Nhờ các bạn viết giúp code lọc dữ liệu trong file đính kèm. Dữ liệu nguồn bên sheet Du lieu. Kết quả mong muốn như sheet Ket qua.
Thanks !
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Anh Nghĩa test cho em Code này nhé. Tks anh!
PHP: 
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 Sub
 
Upvote 0
ndu96081631 đã viết:
Toàn là các ĐẠI CA xuất chiêu hết cả rồi, em làm sao có cơ hội đây?
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

Hay tại quả này dễ quá! (nói trúng tim đen luôn)
ndu mà ra tay chắc còn cỡ 10 dòng là xong.
Hic, mà sao code mình đơn giản, dễ điều chỉnh vậy mà không được Nghĩa test nhỉ, "bùn" ghê
 
Upvote 0
dhn46 đã viết:
Anh Nghĩa test cho em Code này nhé. Tks anh!
PHP: 
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 Sub
Nhấp chuột vào đây để mở rộng...

Mình test code của bạn thì phát hiện lỗi chỗ này
i= 1 thì i-1 sẽ =0 nên Arr(0,1) bị lỗi
Mã: 
For i = 1 To UBound(Arr, 1)
    If Arr(i, 1) = "" Then
        Arr(i, 1) = Arr(i - 1, 1)
    End If
Next
 
Upvote 0
Vừa hết giờ làm viết vội quá còn lỗi em xin sửa lại chút
Mã: 
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) = "" 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 Sub

Mình test code của bạn thì phát hiện lỗi chỗ này
i= 1 thì i-1 sẽ =0 nên Arr(0,1) bị lỗi
Nhấp chuột vào đây để mở rộng...
Dạ 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)
 
Upvote 0
thanhlanh đã viết:
Hay tại quả này dễ quá! (nói trúng tim đen luôn)
ndu mà ra tay chắc còn cỡ 10 dòng là xong.
Hic, mà sao code mình đơn giản, dễ điều chỉnh vậy mà không được Nghĩa test nhỉ, "bùn" ghê
Nhấp chuột vào đây để mở rộng...

Bây giờ em test giúp Anh nhé!

thanhlanh đã viết:
Thêm một cái nữa cho đông vui:
Mã: 
[B]Option Base 1[/B]
Option Explicit
Sub test()
    Dim arrDulieu(), arrKetqua(), DicHoTen, i, k, j, jj, ten
    Set DicHoTen = CreateObject("Scripting.Dictionary")
    [COLOR=#ff0000]Sheets("Du lieu").Select[/COLOR]
    [COLOR=#ff0000]arrDulieu = Sheets("Du lieu").Range([D5], [D65536].End(xlUp)).Offset(, -2).Resize(, 5).Value[/COLOR]
    [B]ReDim arrKetqua(UBound(arrDulieu, 1), 5)[/B]
    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
[COLOR=#ff0000]    Sheets("Ket qua").Select
    With Range("A23")
        .Resize(k, 5).Value = arrKetqua
        .Resize(k, 5).Sort Range("A23"), 1
        .Resize(k).ClearContents
    End With[/COLOR]
End Sub
Nhấp chuột vào đây để mở rộng...

Đầu tiên Anh đã chọn Option Base 1 nói nôm na là bắt đầu số thứ tự của mảng lấy từ 1 (nếu thay 1 là 0 thì bắt đầu từ 0). Nhìn vào đó ta biết anh sẽ ghi ReDim arrKetqua(UBound(arrDulieu, 1), 5), nếu ta không đặt nó thì ta cũng có thể ghi ReDim arrKetqua(1 To UBound(arrDulieu, 1), 1 To 5), chỉ nói rộng ra thôi, cái này cũng chẳng ảnh hưởng gì đến code của Anh.

Cách mà code anh chạy dựa vào mục tên và mục số thứ tự để tìm chi tiết, sau đó gán mỗi mục tương ứng với một số thứ tự, rồi sắp xếp lại theo số thứ tự đã gán, cuối cùng xóa đi cột thứ tự.

Theo yêu cầu của chủ topic thì như vậy đã đạt đúng yêu cầu. Tuy nhiên, nếu như chủ topic lại thêm yêu cầu về số thứ tự của một mục, chắc code của anh hơi khó chỉnh sửa lại.

Về thời gian đã test trên 27,000 dòng đã có tốc độ 1.39s, như vậy cũng khá nhanh.

Về thuật toán em xin mạn phép bàn một chút:

Để giảm thời gian chạy ít nhiều trên code, người ta hiếm sử dụng SheetX.Select mà tham chiếu ngay trên địa chỉ Range luôn:

Thay vì:

Mã: 
    [COLOR=#ff0000]Sheets("Du lieu").Select[/COLOR]
    arrDulieu = Sheets("Du lieu").Range([D5], [D65536].End(xlUp)).Offset(, -2).Resize(, 5).Value

và:
Mã: 
    [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 With

Thì nên chỉnh lại như vầy:

Mã: 
arrDulieu = Range([COLOR=#0000ff]Sheets("Du lieu")[/COLOR].[D5], [COLOR=#0000ff]Sheets("Du lieu")[/COLOR].[D65536].End(xlUp)).Offset(, -2).Resize(, 5).Value

và như vầy:

Mã: 
    With Sheets("Ket qua").Range("A4")
        .Resize(k, 5).Value = arrKetqua
        .Resize(k, 5).Sort Range("A4"), 1
        .Resize(k).ClearContents
    End With

Nói chung code của Anh cũng cho tốc độ nhanh và cũng đã đúng yêu cầu của tác giả topic này. Một số ý kiến của em là vậy.
 
Lần chỉnh sửa cuối:
Upvote 0
Với bài này anh em nào có thể giải ra kết quả theo yêu cầu của tác giả mà không dùng dictionary. Chỉ là vui chơi thôi chứ em không dám có ý thách đố nha các anh. Vì cũng khá lâu rồi mới có 1 bài hấp dẫn thế này.
 
Lần chỉnh sửa cuối:
Upvote 0
dhn46 đã viết:
Vừa hết giờ làm viết vội quá còn lỗi em xin sửa lại chút
Mã: 
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) = "" 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 Sub


Dạ 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)
Nhấp chuột vào đây để mở rộng...

Bạn QuangHai đã nói đúng, hình như bạn chưa sửa được vấn đề này:

Mã: 
' 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

Về nguyên tắc, với i = 1 mà Arr(i - 1, 1) thì code này đã bị lỗi ngay "vòng giữ xe" rồi! Nên code này chỉ cần sửa lại đơn giản như sau:

Mã: 
For 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
Next

Về thời gian test thử trên 27000 dòng với 3 lần chạy thử (sau khi sửa lại 1 thành 2) thì thời gian chạy khoảng 1.6s.
 
Upvote 0
quanghai1969 đã viết:
Với bài này anh em nào có thể giải ra kết quả theo yêu cầu của tác giả mà không dùng dictionary. Chỉ là vui chơi thôi chứ em không dám có ý thách đố nha các anh. Vì cũng khá lâu rồi mới có 1 bài hấp dẫn thế này.
Nhấp chuột vào đây để mở rộng...

Vấn đề này chỉ có chép ra một cột phụ rồi sort lại theo thứ tự, từ đó lọc trên mảng thôi. Không biết QuangHai có còn cách nào khác không?
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Vấn đề này chỉ có chép ra một cột phụ rồi sort lại theo thứ tự, từ đó lọc trên mảng thôi. Không biết QuangHai có còn cách nào khác không?
Nhấp chuột vào đây để mở rộng...
Mì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

PHP: 
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 Sub
 
Upvote 0
quanghai1969 đã viết:
Mì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

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
   [COLOR=#ff0000][B].Range(.[C5], .[D65536].End(3).Offset(, 2)).Sort key1:=.[C3][/B][/COLOR]
   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 Sub
Nhấp chuột vào đây để mở rộng...

Mình đã nói rồi, không dùng Sort thì không giải quyết được vấn đề về lọc duy nhất đâu!
 
Upvote 0
Rất vui mừng vì bài mình cuôí cùng cũng được "chấm", cảm ơn Hoàng Trọng Nghĩa. Bây giờ cứ xem như mình là trò đang lên thớt và phản biện nhé.


Hoàng Trọng Nghĩa đã viết:
Bây giờ em test giúp Anh nhé!
Đầu tiên Anh đã chọn Option Base 1 nói nôm na là bắt đầu số thứ tự của mảng lấy từ 1 (nếu thay 1 là 0 thì bắt đầu từ 0). Nhìn vào đó ta biết anh sẽ ghi ReDim arrKetqua(UBound(arrDulieu, 1), 5), nếu ta không đặt nó thì ta cũng có thể ghi ReDim arrKetqua(1 To UBound(arrDulieu, 1), 1 To 5), chỉ nói rộng ra thôi, cái này cũng chẳng ảnh hưởng gì đến code của Anh.
Nhấp chuột vào đây để mở rộng...
Cá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.

Hoàng Trọng Nghĩa đã viết:

Theo yêu cầu của chủ topic thì như vậy đã đạt đúng yêu cầu. Tuy nhiên, nếu như chủ topic lại thêm yêu cầu về số thứ tự của một mục, chắc code của anh hơi khó chỉnh sửa lại.
Nhấp chuột vào đây để mở rộng...
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.

Hoàng Trọng Nghĩa đã viết:
Về thuật toán em xin mạn phép bàn một chút:

Để giảm thời gian chạy ít nhiều trên code, người ta hiếm sử dụng SheetX.Select mà tham chiếu ngay trên địa chỉ Range luôn
Nhấp chuột vào đây để mở rộng...
Ờ, 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.
 
Upvote 0
thanhlanh đã viết:
Rất vui mừng vì bài mình cuôí cùng cũng được "chấm", cảm ơn Hoàng Trọng Nghĩa. Bây giờ cứ xem như mình là trò đang lên thớt và phản biện nhé.


Cá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.
Nhấp chuột vào đây để mở rộng...

Khi chọn qua một sheet khác, nếu sheet này có đặt 2 sự kiện:

PHP: 
Private Sub Worksheet_Activate()

End Sub

Private Sub Worksheet_Deactivate()

End Sub

Thì các sự kiện này sẽ chạy, chắc anh không muốn chúng nó chạy khi anh đang chạy code chứ? Vì vậy tốt hơn hết ta đừng Select sheet gì cả.
 
Upvote 0
Mình đã nói rồi, không dùng Sort thì không giải quyết được vấn đề về lọc duy nhất đâu!
Nhấp chuột vào đây để mở rộng...
Vậ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à.
PHP: 
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 Sub
 
Upvote 0
dhn46 đã viết:
Vậ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à.
PHP: 
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 Sub
Nhấp chuột vào đây để mở rộng...
Đúng rồi, còn thêm phương án dùng advancefilter trích lọc duy nhất và sau đó có thể không dùng Dic.
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Mình đã nói rồi, không dùng Sort thì không giải quyết được vấn đề về lọc duy nhất đâu!
Nhấp chuột vào đây để mở rộng...
Hí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à
Với đề bài này, nếu không cho sử dụng Dic, Sort, Mảng, Bộ Lọc vẫn có thể giải quyết được ( dĩ nhiên code nó rườm ra & tốc độ thì "xi-ma-chao", hihi)
Trong bài chỉ là một trong nhiều cách giải xử lý hoàn toàn trên sheet ( cứ Ạc, Ạc mãi cũng chán)
Híc
 

File đính kèm

Upvote 0
Bây giờ, trên file này tôi gửi lên, bạn nào Không dùng Dictionary, không dùng AvancedFilter chỉ xử lý trên mảng thì đưa lên phương án.

Cách của tôi:

PHP: 
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 Sub
 

File đính kèm

Upvote 0
Hoàng Trọng Nghĩa đã viết:
Bây giờ, trên file này tôi gửi lên, bạn nào Không dùng Dictionary, không dùng AvancedFilter chỉ xử lý trên mảng thì đưa lên phương án.

Cách của tôi:

PHP: 
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 Sub
Nhấp chuột vào đây để mở rộng...

Hic anh Nghĩa ơi bài toán này mình xử lý không tới 10 dòng lệnh đấy nhé
Chắc anh không nhớ là những chiêu này mình học của anh đấy.

Mã: 
Sub 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 Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Một cách nữa
Mã: 
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 Sub
Híc, Dzui
 
Upvote 0
concogia đã viết:
Một cách nữa
Mã: 
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 Sub
Híc, Dzui
Nhấp chuột vào đây để mở rộng...

Cách của anh Cò thật độc đáo, nhưng chưa đúng anh ơi. Giả sử có Chuỗi Hoàng Trọng nằm khoảng giữa trong vùng dữ liệu thì code anh tèo rồi.. hic
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

vnxgiokinhtoi
Nhờ giúp đỡ công thức lưu dữ liệu và mở lại dữ liệu cũ đã save (1 người xem)
Trả lời
4
Đọc
138
le_vis
L
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
17
Đọc
3K
chienthang2682
C
C
Tải kết quả xổ số 3 miền về excel (1 người xem)
    • Thích
3 4 5
Trả lời
98
Đọc
13K
HNam_Phan
H
S
Xuất các bảng công phụ từ bảng công chính trong gg sheet
Trả lời
0
Đọc
20
sirhungvla
S
T
Nhờ ACE chỉ giáo công thức Gộp nhiều dữ liệu vào một ô trong excel
Trả lời
11
Đọc
281
Hoàng Tuấn 868
H
L
Xin giúp đỡ đổi màu chữ trong mathtype powerpoint sang màu đen
Trả lời
0
Đọc
63
LINHCM
L
PhanTuHuong
Nên chọn điện thoại nào?
2
Trả lời
21
Đọc
1K
minhminh27
minhminh27
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
264
Đọc
28K
lilknighthood
L
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
    • Yêu thích
Trả lời
9
Đọc
400
Nguyễn Duy Tuân
Nguyễn Duy Tuân
Manhhung90
Tạo nút bấm để xoá nhanh trang trong file word.
Trả lời
3
Đọc
111
PhanTuHuong
PhanTuHuong
H
Hàm Evaluate bị lỗi khi mở lại
2
Trả lời
23
Đọc
297
ptm0412
ptm0412
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Buồn
    • Cười
Trả lời
5
Đọc
232
SA_DQ
SA_DQ
Nguyễn Duy Tuân
Lập trình VBA với Google Drive, OneDrive, DropBox cho Upload-Download-Copy-Move...
    • Cảm ơn
    • Thích
Trả lời
4
Đọc
328
quyenpv
quyenpv
hungmanh.th1
Lỗi không trả về Giá trị 0 trong excel
    • Cười
Trả lời
5
Đọc
80
hungmanh.th1
hungmanh.th1
HeSanbi
  • Question Question
VBA nâng cao: Nhúng tập tin vào trang tính hoặc trích xuất chúng nhanh chóng
    • Thích
    • Cảm ơn
Trả lời
0
Đọc
158
HeSanbi
HeSanbi
nguyễn tiến tú
file CALCULATING rất chậm em nhờ các anh chị xem giúp em ạ
Trả lời
7
Đọc
396
tranhungdao12a3
T
T
  • Question Question
Xin thầy/cô và anh chị giúp đỡ cách điền thông tin ca kíp trực trong bảng Excel bằng VBA
Trả lời
2
Đọc
159
tiennd67
T
H
HELP! HÀM LẤY THÁNG/ NĂM TRONG EXCEL
Trả lời
5
Đọc
141
ptm0412
ptm0412
H
Em hỏi vì sao khi file googlesheet của em thì code chạy
Trả lời
2
Đọc
68
Hoale85
H
4
EXCEL TỰ ĐỘNG MỞ TRÊN WEB
Trả lời
9
Đọc
288
4545
4
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom