code VBA copy 2 cột thành 1 cột loại bỏ khoảng trắng và trùng lặp

[Dennisphan94]

Xin chào mọi người

mọi người có thể giúp 1 code vba để copy 2 cột trong file thành 1 cột loại bỏ khoảng trắng và trùng lặp
cảm ơn mọi người

 

[Nhattanktnn]

Xin chào mọi người

mọi người có thể giúp 1 code vba để copy 2 cột trong file thành 1 cột loại bỏ khoảng trắng và trùng lặp
cảm ơn mọi người

1/ Đăng bài sai box, vào box lập trình
2/ Kết quả giả định, muốn trả về như nào phải ghi chú trong file
Sửa đi rồi bàn tiếp nha bạn

 

[Dennisphan94]

1/ Đăng bài sai box, vào box lập trình
2/ Kết quả giả định, muốn trả về như nào phải ghi chú trong file
Sửa đi rồi bàn tiếp nha bạn

xin lỗi bạn , mình đăng bài nhưng không hiểu nguyên tắc , để mình sửa lại

 

[Nhattanktnn]

xin lỗi bạn , mình đăng bài nhưng không hiểu nguyên tắc , để mình sửa lại

Nếu bạn không tạo bài mới thì có thể nhờ mod di chuyển bài sang box lập trình:

Option Explicit
Sub Combine()
Dim Dic As Object, I As Long, J As Long, Lr As Long, K As Long, Txt As String, sArr(), dArr()
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Transaction")
    Lr = .Columns("A:B").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    If Lr < 2 Then Exit Sub
    sArr = .Range("A2:B" & Lr).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
        With Dic
            For J = 1 To UBound(sArr, 2)
                For I = 1 To UBound(sArr, 1)
                    Txt = Replace(sArr(I, J), " ", "")
                        If Not .exists(Txt) And Len(Txt) Then
                            K = K + 1
                            .Add Txt, K
                            dArr(K, 1) = Txt
                        End If
                Next
            Next
        End With
    .Range("D2:D" & .Rows.Count).ClearContents
    .Range("D2").Resize(K) = dArr
End With
Set Dic = Nothing
End Sub

 

[VetMini]

Trời đất, bài này chỉ việc copy dữ liệu, remove duplicates, rồi delete cái dòng trống.
Chả nhẽ lười biếng đến phải dùng ma-cơ-rô.

 

[PacificPR]

Máy nhà mình cho ra con Ma Cà Rồng như thế này thớt

Sub Macro2()
    Dim Er As Long, LastRow As Long
    Range("D2:D" & Rows.Count).ClearContents
    Er = Range("A" & Rows.Count).End(xlUp).Row
    Range("A2:A" & Er).SpecialCells(xlCellTypeConstants, 23).Copy Range("D2")
    Er = Range("D" & Rows.Count).End(xlUp).Row
    Range("D1:$D" & Er).RemoveDuplicates Columns:=1, Header:=xlYes
    Er = Range("B" & Rows.Count).End(xlUp).Row
    LastRow = Range("D" & Rows.Count).End(xlUp).Row
    Range("B2:B" & Er).SpecialCells(xlCellTypeConstants, 23).Copy Range("D" & LastRow + 1)
    LastRow = Range("D" & Rows.Count).End(xlUp).Row
    Range("D1:$D" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

 

[ndu96081631]

Máy nhà mình cho ra con Ma Cà Rồng như thế này thớt

Sub Macro2()
    Dim Er As Long, LastRow As Long
    Range("D2:D" & Rows.Count).ClearContents
    Er = Range("A" & Rows.Count).End(xlUp).Row
    Range("A2:A" & Er).SpecialCells(xlCellTypeConstants, 23).Copy Range("D2")
    Er = Range("D" & Rows.Count).End(xlUp).Row
    Range("D1:$D" & Er).RemoveDuplicates Columns:=1, Header:=xlYes
    Er = Range("B" & Rows.Count).End(xlUp).Row
    LastRow = Range("D" & Rows.Count).End(xlUp).Row
    Range("B2:B" & Er).SpecialCells(xlCellTypeConstants, 23).Copy Range("D" & LastRow + 1)
    LastRow = Range("D" & Rows.Count).End(xlUp).Row
    Range("D1:$D" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

Cứ chọn cho dư ra đến 500000 dòng cũng được:

Sub Test()
  Sheet1.Range("A1:A500000").Copy Sheet1.Range("D1")
  Sheet1.Range("B2", Sheet1.Range("B500000").End(xlUp)).Copy Sheet1.Range("D500000").End(xlUp).Offset(1)
  Sheet1.Range("D1:D500000").RemoveDuplicates 1, xlYes
  Sheet1.Range("D1:D500000").SpecialCells(xlCellTypeBlanks).Delete xlUp
End Sub

Bài này tôi làm bằng tay chưa đến 1 phút