Nhờ giúp đỡ code copy duy nhất và đảo chiều 2 cột

[Eric.Shen]

Chào các bác!
Em đang có một bài toán cần copy các cặp duy nhất và đảo chiều, nhờ các bác giúp em một code để thực hiện thao tác này với ạ
Cụ thể dữ liệu như bảng 1 và kết quả như bảng 2 như trong tệp đính kèm ạ
Em cảm ơn ạ!

 

[Hai Lúa Miền Tây]

Chào các bác!
Em đang có một bài toán cần copy các cặp duy nhất và đảo chiều, nhờ các bác giúp em một code để thực hiện thao tác này với ạ
Cụ thể dữ liệu như bảng 1 và kết quả như bảng 2 như trong tệp đính kèm ạ
Em cảm ơn ạ!

Bạn thử code sau nhé:

Sub LayMa()
     With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO"""
        Sheet1.Range("H3").CopyFromRecordset .Execute("Select Distinct F1,F2 From [Sheet1$A3:B] Where F1 Is Not Null Union All Select Distinct F2,F1 From [Sheet1$A3:B] Where F1 Is Not Null")
    End With
End Sub

Hoặc:

Sub LayMa1()
     With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO"""
        Sheet1.Range("H3").CopyFromRecordset .Execute("Select F1, F2 From [Sheet1$A3:B] Where F1 Is Not Null Union Select F2, F1 From [Sheet1$A3:B] Where F1 Is Not Null")
    End With
End Sub

 

[Eric.Shen]

Bạn thử code sau nhé:

Sub LayMa()
     With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO"""
        Sheet1.Range("H3").CopyFromRecordset .Execute("Select Distinct F1,F2 From [Sheet1$A3:B] Where F1 Is Not Null Union All Select Distinct F2,F1 From [Sheet1$A3:B] Where F1 Is Not Null")
    End With
End Sub

Hoặc:

Sub LayMa1()
     With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO"""
        Sheet1.Range("H3").CopyFromRecordset .Execute("Select F1, F2 From [Sheet1$A3:B] Where F1 Is Not Null Union Select F2, F1 From [Sheet1$A3:B] Where F1 Is Not Null")
    End With
End Sub

Em cảm ơn bác rất nhiều ạ,
Em thấy các code ADO này rất ngắn gọn và hiệu quả nhưng tiếc là không hiểu sao máy em lại không chạy được bác ạ.

 

[Maika8008]

Em cảm ơn bác rất nhiều ạ,
Em thấy các code ADO này rất ngắn gọn và hiệu quả nhưng tiếc là không hiểu sao máy em lại không chạy được bác ạ.
View attachment 292891

Bạn thay Microsoft.ACE.OLEDB.12.0 băng Microsoft.ACE.OLEDB.15.0 hoặc 16 xem.

 

[Eric.Shen]

Bạn thay Microsoft.ACE.OLEDB.12.0 băng Microsoft.ACE.OLEDB.15.0 hoặc 16 xem.

Em thử rồi mà vẫn không được bác ạ, em dùng Office 2016 không rõ đang thiếu cái gì mà không chạy được

 

[HUONGHCKT]

Em thử rồi mà vẫn không được bác ạ, em dùng Office 2016 không rõ đang thiếu cái gì mà không chạy được

Nếu vẫn không được, trong khi chờ đợi có thể tham khảo code này xem sao.

Option Explicit

Sub Dao()
Dim i&, Lr&, t&
Dim Dic As Object, Key
Dim Arr(), Res()
With Sheet1
    Lr = .Cells(10000, "A").End(xlUp).Row
    Arr = .Range("A3:B" & Lr).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim Res(1 To UBound(Arr) * 2, 1 To 2)
    For i = 1 To UBound(Arr)
        Key = Arr(i, 1) & "|" & Arr(i, 2)
        If Not Dic.Exists(Key) Then
            t = t + 1: Dic.Add (Key), t
            Res(t, 1) = Arr(i, 1)
            Res(t, 2) = Arr(i, 2)
        End If
    Next i
    For Each Key In Dic.Keys
        t = t + 1
            Res(t, 1) = Split(Key, "|")(1)
            Res(t, 2) = Split(Key, "|")(0)
    Next Key
    If t Then .Range("J3").Resize(t, 2) = Res
End With
Msgbox "Done"
End Sub

 

[Eric.Shen]

Nếu vẫn không được, trong khi chờ đợi có thể tham khảo code này xem sao.

Option Explicit

Sub Dao()
Dim i&, Lr&, t&
Dim Dic As Object, Key
Dim Arr(), Res()
With Sheet1
    Lr = .Cells(10000, "A").End(xlUp).Row
    Arr = .Range("A3:B" & Lr).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim Res(1 To UBound(Arr) * 2, 1 To 2)
    For i = 1 To UBound(Arr)
        Key = Arr(i, 1) & "|" & Arr(i, 2)
        If Not Dic.Exists(Key) Then
            t = t + 1: Dic.Add (Key), t
            Res(t, 1) = Arr(i, 1)
            Res(t, 2) = Arr(i, 2)
        End If
    Next i
    For Each Key In Dic.Keys
        t = t + 1
            Res(t, 1) = Split(Key, "|")(1)
            Res(t, 2) = Split(Key, "|")(0)
    Next Key
    If t Then .Range("J3").Resize(t, 2) = Res
End With
Msgbox "Done"
End Sub

Em cảm ơn bác,
Kết quả đúng rồi ạ,
Bác có thể giải thích giúp em đoạn này không ạ?
em cũng muốn tìm hiểu một chút ạ
Res(t, 1) = Split(Key, "|")(1)
Res(t, 2) = Split(Key, "|")(0)

 

[HUONGHCKT]

Em cảm ơn bác,
Kết quả đúng rồi ạ,
Bác có thể giải thích giúp em đoạn này không ạ?
em cũng muốn tìm hiểu một chút ạ
Res(t, 1) = Split(Key, "|")(1)
Res(t, 2) = Split(Key, "|")(0)

Tôi không học bài bản chỉ giải thích cho bạn theo ý hiểu của tôi thôi:
Như ở trên ta có dòng code : Key =Arr(i,1)&"|"&Arr(i,2) có nghĩa là key này = A|B (có dấu gạch đứng phân cách 2 ký tự A và B)
Hàm (hay phương thức hay gì gì đó) Split là tách các Phần tử của 1 đối tượng cần tách (ở đây là Key) thành các thành phần (phần tử) thông qua 1 dấu hiệu (ở đây là nét "|") và đưa nó vào mảng (mảng này có số thứ tự các phần tử bắt đầu từ 0).
Quay lại với bài trên thì Res(t,1)=Split(key,"|")(0) .Tức là phần tử dòng t, cột 1) có giá trị là phần tử đầu tiên của mảng được tạo bởi Split đã nói ở trên.
Bạn có thể thử lại bằng cách : copy toàn bộ bài viết này, paste vào 1 ô nào đó ( ví dụ ô A1) và thử Code sau

Sub Thu()
Dim S,I&

S=Split(Sheet1.Range("A1")," ")

For i= Lbound(S) to Ubound(S)
Msgbox  S(i)
next i
End Sub

Bạn nhấn f8 và xem kết quả là gì và tự rút ra kết luận.
Chúc bạn Thành công.

 

[Eric.Shen]

Tôi không học bài bản chỉ giải thích cho bạn theo ý hiểu của tôi thôi:
Như ở trên ta có dòng code : Key =Arr(i,1)&"|"&Arr(i,2) có nghĩa là key này = A|B (có dấu gạch đứng phân cách 2 ký tự A và B)
Hàm (hay phương thức hay gì gì đó) Split là tách các Phần tử của 1 đối tượng cần tách (ở đây là Key) thành các thành phần (phần tử) thông qua 1 dấu hiệu (ở đây là nét "|") và đưa nó vào mảng (mảng này có số thứ tự các phần tử bắt đầu từ 0).
Quay lại với bài trên thì Res(t,1)=Split(key,"|")(0) .Tức là phần tử dòng t, cột 1) có giá trị là phần tử đầu tiên của mảng được tạo bởi Split đã nói ở trên.
Bạn có thể thử lại bằng cách : copy toàn bộ bài viết này, paste vào 1 ô nào đó ( ví dụ ô A1) và thử Code sau

Sub Thu()
Dim S,I&

S=Split(Sheet1.Range("A1")," ")

For i= Lbound(S) to Ubound(S)
Msgbox  S(i)
next i
End Sub

Bạn nhấn f8 và xem kết quả là gì và tự rút ra kết luận.
Chúc bạn Thành công.

Cảm ơn bác đã giải thích. em sẽ nghiên cứu thêm ạ

 

[Phương Phương mito]

Nếu vẫn không được, trong khi chờ đợi có thể tham khảo code này xem sao.

Option Explicit

Sub Dao()
Dim i&, Lr&, t&
Dim Dic As Object, Key
Dim Arr(), Res()
With Sheet1
    Lr = .Cells(10000, "A").End(xlUp).Row
    Arr = .Range("A3:B" & Lr).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    ReDim Res(1 To UBound(Arr) * 2, 1 To 2)
    For i = 1 To UBound(Arr)
        Key = Arr(i, 1) & "|" & Arr(i, 2)
        If Not Dic.Exists(Key) Then
            t = t + 1: Dic.Add (Key), t
            Res(t, 1) = Arr(i, 1)
            Res(t, 2) = Arr(i, 2)
        End If
    Next i
    For Each Key In Dic.Keys
        t = t + 1
            Res(t, 1) = Split(Key, "|")(1)
            Res(t, 2) = Split(Key, "|")(0)
    Next Key
    If t Then .Range("J3").Resize(t, 2) = Res
End With
Msgbox "Done"
End Sub

A Hương muôn năm !!!