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

[Tình nghĩa giang hồ]

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

 

[Hoàng Nhật Phương]

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

 

[Hoàng Nhật Phương]

Chào anh chị em có vấn đề này nhờ anh chị hỗ trợ giúp em
..
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.
..

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

 

[Nhattanktnn]

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

Code này thì bỏ luôn cái regex kia nha, bạn test lại:

Option Explicit
Option Compare Text 'Phan biet hoa-thuong thi bo dong nay
Sub SplitData()
Dim a(), b(), i&, j&, k&, x&, tmp
With Sheets("Sheet1")
    a = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
    ReDim b(1 To UBound(a))
    For i = 1 To UBound(a)
        tmp = Split(a(i, 1))
        For j = 0 To UBound(tmp)
            If Not tmp(j) Like "*[!a-zA-Z]*" Then
                For x = 1 To k
                    If tmp(j) = b(x) Then Exit For
                Next
                If x > k Then
                    k = k + 1
                    If k > UBound(b) Then ReDim Preserve b(1 To k + 10)
                    b(k) = tmp(j)
                End If
            End If
        Next
    Next
    .Range("R2").Resize(k) = Application.Transpose(b)
End With
End Sub

 

[Tình nghĩa giang hồ]

Dạ em cảm ơn anh Nhật Phương và anh Nhattanktnn nhiều.

 

[Nhattanktnn]

Dạ em cảm ơn anh Nhật Phương và anh Nhattanktnn nhiều.

Nhật Phương là chị nhé (Oanh Thơ xinh đẹp)

 

[Tình nghĩa giang hồ]

Nhật Phương là chị nhé (Oanh Thơ xinh đẹp)

Bữa em cũng nói chị Nhật Phương, mà anh Hữu Thắng ghẹo, nên em tưởng là Nhật Phương là anh.........