Hỗ trợ chuyển đổi bảng thành 1 cột, xóa trùng

Chia sẻ bởi:hands

★★★★★

‹ Em xin giúp đỡ ạ: Tìm số... UDF FilterA và FilterV – Tận dụng... ›

Quảng cáo

Chào anh chị em có vấn đề này nhờ anh chị hỗ trợ giúp em

Em có 1 bảng dữ liệu từ B2 đến P1000
Em muốn chuyển dữ liệu bảng B2:B1000 này vào 1 cột Q bắt đầu từ Q2
Em đã code được việc di chuyển, nhưng có một vấn đề là xóa trùng thì em không làm được.
Em phải viết thêm bằng cách ăn gian: thêm Remove dulicate.
Trường hợp này cho em hỏi là code viết bằng mảng có cách nào loại bỏ trùng từ code không ? Hay phải viết theo kiểu từ điển thì mới xóa trùng được anh chị.
Nhờ anh chị xem giúp em trường hợp này.
Em mong muốn là xóa trùng trực tiếp trong mảng luôn.
Em cảm ơn anh chị.
Sub Bang_to_Cot()
Sheet1.Range("Q2:Q5000").ClearContents
Dim arr(), r As Long, c As Long, a As Long, kq()
arr = Sheet1.Range("B2:P1000")
ReDim kq(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 1)
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If arr(r, c) <> "" Then
a = a + 1
kq(a, 1) = arr(r, c)
End If
Next
Next
Sheet1.Range("Q2").Resize(a, 1).Value = kq

'Remove Dulicate bằng Record Macro
Application.Goto Reference:="R2C17:R1000C17"
    ActiveSheet.Range("$Q$1:$Q$1000").RemoveDuplicates Columns:=1, Header:= _
        xlYes
End Sub

Bạn tham khảo:

Option Explicit

Sub test()

Dim sheet As Worksheet
    Set sheet = ThisWorkbook.Worksheets("Sheet1")

Dim r As Long, c As Long, i As Long, j As Long, k As Long
    r = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row
    c = sheet.Cells(1, sheet.Columns.Count).End(xlToLeft).Column
    If (r < 2) Or (c < 2) Then Exit Sub

Dim dic As Object, arr As Variant, res As Variant, var As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    arr = sheet.Range("B1").Resize(r, c - 1)
    ReDim res(1 To r * c, 1 To 1)
    For i = 2 To r
        For j = 1 To c - 2 'Neu xoa cot Ket qua chinh lai la c - 1
            var = arr(i, j)
            If Len(var) > 0 Then
                If Not dic.Exists(var) Then
                    k = k + 1: dic.Add var, k
                    res(k, 1) = var
                End If
            End If
        Next j
    Next i

If k Then sheet.Cells(2, c + 1).Resize(k).Value = res 

End Sub

Bạn tha khảo thêm cách không sử dụng từ điển:

Function valueExists(ByVal res As Variant, ByVal value As Variant, ByVal k As Long) As Boolean
    Dim i As Long
    For i = LBound(res, 1) To k
        If res(i, 1) = value Then
            valueExists = True
            Exit For
        End If
    Next i
End Function

Sub Không_Dùng_Dictionary()

Dim sheet As Worksheet
    Set sheet = ThisWorkbook.Worksheets("Sheet1")

Dim r As Long, c As Long, i As Long, j As Long, k As Long
    r = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row
    c = sheet.Cells(1, sheet.Columns.Count).End(xlToLeft).Column
    If (r < 2) Or (c < 2) Then Exit Sub

Dim arr As Variant, res As Variant, var As Variant
    arr = sheet.Range("B1").Resize(r, c - 1).Value2
    ReDim res(1 To r * c, 1 To 1)
    k = 1
    For i = 2 To r
        For j = 1 To c - 2 'Neu xoa cot Ket qua chinh lai la c - 1
            var = arr(i, j)
            If Len(var) > 0 Then
                If Not valueExists(res, var, k) Then
                    res(k, 1) = var
                    k = k + 1
                End If
            End If
        Next j
    Next i

If k Then sheet.Cells(2, c + 1).Resize(k).value = res

End Sub

www.giaiphapexcel.com/diendan/threads/h%E1%BB%97-tr%E1%BB%A3-chuy%E1%BB%83n-%C4%91%E1%BB%95i-b%E1%BA%A3ng-th%C3%A0nh-1-c%E1%BB%99t-x%C3%B3a-tr%C3%B9ng.165913/