Tách dữ liệu (1 người xem)

[toandiennuoc123]

Chào các bạn ! Tôi muốn nhờ các bạn viết giúp tôi 1 Sub tách dữ liệu trùng và không trùng trong 1 cột thành 2 cột. Cám ơn các bạn.

 

[dhn46]

Bạn thử sub này xem có đúng ý không?

Sub Tach()
    Dim i As Long, Tmp As Long
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Not Dic.Exists(Tmp) Then
            Dic.Add Tmp, i
        Else
            Dic.Item(Tmp) = Dic.Item(Tmp) & "Y"
        End If
    Next
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Right(Dic.Item(Tmp), 1) = "Y" Then
            Res(i, 1) = Tmp
        Else
            Res(i, 2) = Tmp
        End If
    Next
    Range("E3").Resize(UBound(Arr, 1), 2) = Res
End Sub

 

[giola]

Bạn thử sub này xem có đúng ý không?

Sub Tach()
    Dim i As Long, Tmp As Long
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Not Dic.Exists(Tmp) Then
            Dic.Add Tmp, i
        Else
            Dic.Item(Tmp) = Dic.Item(Tmp) & "Y"
        End If
    Next
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Right(Dic.Item(Tmp), 1) = "Y" Then
            Res(i, 1) = Tmp
        Else
            Res(i, 2) = Tmp
        End If
    Next
    Range("E3").Resize(UBound(Arr, 1), 2) = Res
End Sub

Như thê này cho nó sành điệu (chỉ là phương án khác), mỗi cái có cái hay riêng

Sub Tach()
    Dim i As Long, Tmp As Variant
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Dic.Exists(Tmp) Then
            If Dic.Item(Tmp) <> -1 Then Res(Dic.Item(Tmp), 1) = Tmp
            Res(i, 1) = Tmp
            Dic.Item(Tmp) = -1
        Else
            Dic.Add Tmp, i
        End If
    Next
    
    For Each Tmp In Dic.Keys
        If Dic.Item(Tmp) <> -1 Then Res(Dic.Item(Tmp), 2) = Tmp
    Next
    
    Range("E3").Resize(UBound(Arr, 1), 2) = Res
    Set Dic = Nothing
End Sub

 

[giola]

Như thê này cho nó sành điệu (chỉ là phương án khác), mỗi cái có cái hay riêng

Sub Tach()
    Dim i As Long, Tmp As Variant
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Dic.Exists(Tmp) Then
            If Dic.Item(Tmp) <> -1 Then Res(Dic.Item(Tmp), 1) = Tmp
            Res(i, 1) = Tmp
            Dic.Item(Tmp) = -1
        Else
            Dic.Add Tmp, i
        End If
    Next
    
    For Each Tmp In Dic.Keys
        If Dic.Item(Tmp) <> -1 Then Res(Dic.Item(Tmp), 2) = Tmp
    Next
    
    Range("E3").Resize(UBound(Arr, 1), 2) = Res
    Set Dic = Nothing
End Sub

Hoặc phương án khác nữa, cho khác kiểu sành điệu

Sub Tach()
    Dim i As Long, n As Long, Tmp As Variant
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    n = UBound(Arr)
    ReDim Res(1 To n, 1 To 2)
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To n
        Tmp = Arr(i, 1)
        If Dic.Exists(Tmp) Then
            If Dic.Item(Tmp) <> -1 Then Res(Dic.Item(Tmp), 1) = Tmp
            Res(i, 1) = Tmp
            Dic.Item(Tmp) = -1
        Else
            Dic.Add Tmp, i
        End If
    Next
    
    For Each Tmp In Dic.Items
        If Tmp <> -1 Then Res(Tmp, 2) = Arr(Tmp, 1)
    Next
    
    Range("E3").Resize(n, 2) = Res
    Set Dic = Nothing
End Sub

 

[VetMini]

Bài này xài công thức tường đối không phức tạp. Lý do tại sao lại đi bỏ dễ rước khó vào vậy?

 

[Đình Phán]

Bài này xài công thức tường đối không phức tạp. Lý do tại sao lại đi bỏ dễ rước khó vào vậy?

Theo lời anh VietMini em làm công thức thử

 

[concogia]

Theo lời anh VietMini em làm công thức thử

Công thức này:

=IF(COUNTIFS($A$3:$A$109,A3)>=2,A3,"")

Nếu thay ">=2" thành ">1" sẽ ngắn hơn tí tẹo
Nếu viết code thì dùng kiểu này chỉ một vòng lặp là có kết quả
Hihi, nói thế thôi, ai muốn làm kiểu gì thì làm, miễn kết quả ok là....."ô- kê" rồi

 

[VetMini]

Code:
Theo như dữ liệu trong file mẫu thì chúng đã được sắp xếp thứ tự.
Nếu đúng như thế thì giải thuật bằng code rất giản dị. Chỉ cần so sánh ô với ô trước và sau nó. Hết
(công thưc cũng vậy)

Nếu dữ liệu trên thực tế không sắp xếp thì chủ thớt cần suy nghĩ lại về cách cho dữ liệu mẫu. Dữ liệu mẫu phải phản ảnh thực tế.

 

[minhquang05]

Hoặc phương án khác nữa, cho khác kiểu sành điệu

Sub Tach()
    Dim i As Long, n As Long, Tmp As Variant
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    n = UBound(Arr)
    ReDim Res(1 To n, 1 To 2)
    
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To n
        Tmp = Arr(i, 1)
        If Dic.Exists(Tmp) Then
            If Dic.Item(Tmp) <> -1 Then Res(Dic.Item(Tmp), 1) = Tmp
            Res(i, 1) = Tmp
            Dic.Item(Tmp) = -1
        Else
            Dic.Add Tmp, i
        End If
    Next
    
    For Each Tmp In Dic.Items
        If Tmp <> -1 Then Res(Tmp, 2) = Arr(Tmp, 1)
    Next
    
    Range("E3").Resize(n, 2) = Res
    Set Dic = Nothing
End Sub

Anh giola có thể cho em xin bản dịch của từng dòng code được không?
Em mới tìm hiểu qua về Range và Cell nên phần mảng này chưa hiểu rõ lắm

 

[Hau151978]

Công thức tại C3=IF(B3="",A3,"")
Nếu dữ liệu chưa sort thì B3=IF(COUNTIF($A$3:$A$109, A3)>1, A3,"")
Nếu dữ liệu đã sort như ví dụ thì B3=IF(OR(A3=A2,A3=A4), A3,"")

 

[giola]

Anh giola có thể cho em xin bản dịch của từng dòng code được không?
Em mới tìm hiểu qua về Range và Cell nên phần mảng này chưa hiểu rõ lắm

Không có bản dịch bạn ơi, vì ngôn ngữ lập trình thì đâu có dịch đâu,

Tuy thế đó là ngôn ngữ English nên cứ theo nghĩa cũng hiểu đôi phần,

CODE gốc là của Dhn46 vậy bạn hãy đề nhi Dhn46 giải thích nhé, tôi đại lãm không bao giờ dịch code, nhất là code người khác viết thì thua.

 

[VetMini]

@dhn46:
Bài này kết quả chỉ ghi ra cột 1 hoặc 2 mà thôi. Code của bạn như vậy có thể thu gọn như sau:

Sub Tach()
    Dim i As Long
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        Dic(Arr(i, 1)) = IIf(Dic.Exists(Arr(i, 1)), 1, 2)[COLOR=#008000] ' nếu có trùng lặp thì cột 1, không thì cột 2[/COLOR]
    Next
    For i = 1 To UBound(Res, 1)
        Res(i, Dic(Arr(i, 1))) = Arr(i, 1)
    Next
    Range("E3").Resize(UBound(Arr, 1), 2) = Res
End Sub

Giải thuật của bài #3 và #4 phức tạp quá, thâu gọn hỏng nổi.

 

[dhn46]

Bài này cũng có thể chỉ sử dụng 1 vòng lặp kết hợp Dic, bạn tham khảo nhé

Sub Tach()
    Dim i As Long, Tmp As Long
    Dim Dic As Object
    Dim Arr(), Res()
    Arr = Range("A3:A" & Range("A65536").End(3).Row)
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Arr, 1)
        Tmp = Arr(i, 1)
        If Not Dic.Exists(Tmp) Then
            Dic.Add Tmp, i
            Res(i, 2) = Tmp
        Else
            Res(i, 1) = Tmp
            If Res(Dic.Item(Tmp), 1) = "" Then Res(Dic.Item(Tmp), 1) = Res(Dic.Item(Tmp), 2)
            Res(Dic.Item(Tmp), 2) = ""
        End If
    Next
    Range("E3").Resize(UBound(Arr, 1), 2) = Res
End Sub