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

[TrungChinhs]

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 !

 

[Hoàng Trọng Nghĩa]

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.

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

Mình đang nói thử trên mảng thôi trời ạ! Đang cố gắng không động tới sheet mà chưa được nè! Cái nãy còn đụng tới ông Sort nên chưa hài lòng.

 

[sealand]

Nhìn vế 2 chữ ký của Nghĩa nên mình góp code này:

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 Sub

 

[Hoàng Trọng Nghĩa]

Nhìn vế 2 chữ ký của Nghĩa nên mình góp code này:

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 Sub

Hay thiệt đó nha! Ngắn gọn mà hiệu quả! Tốc độ nhanh chóng!

 

[concogia]

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

Hihi, 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 Sub

Có thể tạo mảng gán kết quả luôn cũng được

 

[Quang_Hải]

Hay thiƣ! Tốc độ nhanh chóng!

Cách của Sealand cũng bị sót dữ liệu, giống bài 41 của anh Cò

Bài 46 của anh Cò lợi hại thật

 

[Hoàng Trọng Nghĩa]

Cách của Sealand cũng bị sót dữ liệu, giống bài 41 của anh Cò

Bài 46 của anh Cò lợi hại thật

Uh, phải test lẫn nhau để tối ưu code, chứ đinh ninh code mình luôn luôn chính xác là còn hạn chế lắm.

 

[Hoàng Trọng Nghĩa]

Mình mượn code của Bác Cò rồi bỏ cái WorkSheetFunction đi thay vào đó một vòng lặp nữa để không lệ thuộc vào hàm của sheet:

Public 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 Sub

 

[dhn46]

Cho em góp vui với

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

 

[Quang_Hải]

Cho em góp vui với

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

Code 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

For i = 1 To UBound(arr)
For j = i + 1 To UBound(arr)
Khả năng treo máy có thể xảy ra. >>> Code này chắc không được rồi

 

[thanhlanh]

Mình đang nói thử trên mảng thôi trời ạ! Đang cố gắng không động tới sheet mà chưa được nè! Cái nãy còn đụng tới ông Sort nên chưa hài lòng.

Vậy được không, chạy với dữ liệu của Nghĩa, xử lý trên Array (noDic)

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 Sub

 

[concogia]

Mình mượn code của Bác Cò rồi bỏ cái WorkSheetFunction đi thay vào đó một vòng lặp nữa để không lệ thuộc vào hàm của sheet:

Public 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 Sub

Má ơ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 Sub

Híc

 

[Hoàng Trọng Nghĩa]

Má ơ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 Sub

Híc

Đúng vậy, với cách này em nghĩ có thể làm một mảng với nhiều cột đúng không?

 

[ThuNghi]

Theo tôi với dạng bài này thì có Dic rồi sao không sử dụng cho nhanh mà mất công tư duy.
Tôi thấy code của anh ThanhLanh là hợp lý nhất, gán cho cái số TT và sort cho khỏe.
Trường hợp bài này nếu bổ sung thêm dòng công SubTotal trên đầu để cộng DT thì triển khai thêm thế nào.

Nếu dùng Dic và không dùng sort thì theo tôi bài dạng này cần phải 2 for i mới OK.

 

[sealand]

Theo mình tất cả các động tác sử lý trực tiếp trên bảng tính đều chậm rất nhiều lần, nếu dữ liệu lớn thì hậu quả nhỡn tiền.
Kể cả bài trước chỉ là ý tưởng thôi, chứ sẽ lỗi nhiều nhất là mảng kq lớn vượt giới hạn biến chuỗi cũng không ổn. Theo mình nên thế này cho nó lành:

Sub 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

 

[Hoàng Trọng Nghĩa]

Theo tôi với dạng bài này thì có Dic rồi sao không sử dụng cho nhanh mà mất công tư duy.
Tôi thấy code của anh ThanhLanh là hợp lý nhất, gán cho cái số TT và sort cho khỏe.
Trường hợp bài này nếu bổ sung thêm dòng công SubTotal trên đầu để cộng DT thì triển khai thêm thế nào.

Nếu dùng Dic và không dùng sort thì theo tôi bài dạng này cần phải 2 for i mới OK.

Chắc anh chưa xem những giải pháp ở những trang đầu, tất cả có dùng Dictionary cả. Tuy nhiên bắt đầu từ bài 29 của QuangHai mọi người mới "mất công tư duy" cho vui.

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ưng đâu phải không có ích đâu, nó làm cho bộ não mình vận động, tìm hướng đi mới mẽ, rút ra những kinh nghiệm, những bài học từ suy luận của chính bản thân mình, rồi so sánh thiệt hơn, rồi chọn lựa những cách hiệu quả nhất, hơn là copy những cái có sẳn rồi áp dụng, ý kiến của em là như vậy.