Nhờ các bạn giúp code Lấy số không trùng từ 2 cột sang 1 cột (1 người xem)

[Phúc Lộc Thọ]

Mình xin chào các bạn diễn đàn. Mình có 1 bảng tính như mô tả hình ảnh, mình cần 1 mã VBA lọc ra số không trùng . Xin cảm ơn các bạn giúp đỡ.

 

[Thóc Sama]

Mình xin chào các bạn diễn đàn. Mình có 1 bảng tính như mô tả hình ảnh, mình cần 1 mã VBA lọc ra số không trùng . Xin cảm ơn các bạn giúp đỡ.

View attachment 279860

Bạn mình thử code dưới xem nhé!

Sub Loc()
    Dim Dic As Object, Key As String, Arr(), Res(1 To 100, 1 To 1)
    Set Dic = CreateObject("scripting.Dictionary")
    Dim k As Long, i As Long
    On Error Resume Next
    With Sheet1
        Arr = .Range("C3:E19").Value
        For i = 1 To UBound(Arr)
            If Arr(i, 1) <> "" And Not Dic.exists(Arr(i, 1)) Then
                k = k + 1
                Dic.Add (Arr(i, 1)), k
                Res(k, 1) = Arr(i, 1)
            End If
            If Arr(i, 3) <> "" And Not Dic.exists(Arr(i, 3)) Then
                k = k + 1
                Dic.Add (Arr(i, 3)), k
                Res(k, 1) = Arr(i, 3)
            End If
        Next i
        .Range("G3:G100").ClearContents
        .Range("G3").Resize(k, 1).Value = Res
    End With
    Set Dic = Nothing
End Sub

 

[BuiQuangThuan]

Mình xin chào các bạn diễn đàn. Mình có 1 bảng tính như mô tả hình ảnh, mình cần 1 mã VBA lọc ra số không trùng . Xin cảm ơn các bạn giúp đỡ.

View attachment 279860

Nếu code được thì dùng dictionary. Còn không thì copy 2 cột C,E vào cột G rồi remove trùng đi

 

[Phúc Lộc Thọ]

Bạn mình thử code dưới xem nhé!

Sub Loc()
    Dim Dic As Object, Key As String, Arr(), Res(1 To 100, 1 To 1)
    Set Dic = CreateObject("scripting.Dictionary")
    Dim k As Long, i As Long
    On Error Resume Next
    With Sheet1
        Arr = .Range("C3:E19").Value
        For i = 1 To UBound(Arr)
            If Arr(i, 1) <> "" And Not Dic.exists(Arr(i, 1)) Then
                k = k + 1
                Dic.Add (Arr(i, 1)), k
                Res(k, 1) = Arr(i, 1)
            End If
            If Arr(i, 3) <> "" And Not Dic.exists(Arr(i, 3)) Then
                k = k + 1
                Dic.Add (Arr(i, 3)), k
                Res(k, 1) = Arr(i, 3)
            End If
        Next i
        .Range("G3:G100").ClearContents
        .Range("G3").Resize(k, 1).Value = Res
        .Range("G3").Sort = xlAscending
    End With
    Set Dic = Nothing
End Sub

Cảm ơn bạn, Code chạy như ý mình luôn hihi

 

[BuiQuangThuan]

Them cach khác tham khảo

Sub ABC()
Dim sArr(), i&, j&
Dim Dic As Object:      Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("C2:E19").Value
    For i = 2 To UBound(sArr)
        For j = 1 To UBound(sArr, 2)
            If sArr(i, j) <> Empty Then
                If IsNumeric(sArr(i, j)) = True Then
                    If Dic.exists(sArr(i, j)) = False Then
                        Dic.Add (sArr(i, j)), ""
                    End If
                End If
            End If
        Next
    Next
    .Range("G3").Resize(Dic.Count).Value = Application.WorksheetFunction.Transpose(Dic.keys)
    .Range("G4").Resize(Dic.Count).Sort .Range("G3"), xlAscending
End With
End Sub

 

[snow25]

Mình xin chào các bạn diễn đàn. Mình có 1 bảng tính như mô tả hình ảnh, mình cần 1 mã VBA lọc ra số không trùng . Xin cảm ơn các bạn giúp đỡ.

View attachment 279860

Thử code.

Sub abc()
    Dim i As Long, arr, data() As Boolean, min As Long, max As Long, a As Long
    With Sheets("sheet1")
         arr = .Range("C3:E20")
         min = WorksheetFunction.min(.Range("C3:E20"))
         max = WorksheetFunction.max(.Range("C3:E20"))
         ReDim data(min To max)
         For i = 1 To UBound(arr)
             If arr(i, 1) <> Empty Then data(arr(i, 1)) = True
             If arr(i, 3) <> Empty Then data(arr(i, 3)) = True
         Next i
         ReDim kq(1 To max - min, 1 To 1)
         For i = min To max
             If data(i) = True Then
                a = a + 1
                kq(a, 1) = i
             End If
         Next i
         .Range("H3:H100").ClearContents
         .Range("H3").Resize(a).Value = kq
   End With
End Sub

 

[Phúc Lộc Thọ]

Them cach khác tham khảo

Sub ABC()
Dim sArr(), i&, j&
Dim Dic As Object:      Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("C2:E19").Value
    For i = 2 To UBound(sArr)
        For j = 1 To UBound(sArr, 2)
            If sArr(i, j) <> Empty Then
                If IsNumeric(sArr(i, j)) = True Then
                    If Dic.exists(sArr(i, j)) = False Then
                        Dic.Add (sArr(i, j)), ""
                    End If
                End If
            End If
        Next
    Next
    .Range("G3").Resize(Dic.Count).Value = Application.WorksheetFunction.Transpose(Dic.keys)
    .Range("G4").Resize(Dic.Count).Sort .Range("G3"), xlAscending
End With
End Sub

Cảm ơn bạn. Cách của bạn nó lại sai ở chổ lọc cột D không mong muốn, Mình chỉ lọc cột C và cột E thôi, cột D nó là số hay chữ không liên quan gì

 

[BuiQuangThuan]

Mình chỉ lọc cột C và cột E thôi, cột D nó là số hay chữ không liên quan gì

Nếu bạn biết sửa code thì sẽ đạt được mục đích mà

 

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

Mình xin chào các bạn diễn đàn. Mình có 1 bảng tính như mô tả hình ảnh, mình cần 1 mã VBA lọc ra số không trùng . Xin cảm ơn các bạn giúp đỡ.

View attachment 279860

Bạn thử code sau nhé:

Sub GopDL_HLMT()
    Dim strSQL As String
    strSQL = "Select F1 From [Sheet1$C3:C100] " & _
             "Union All Select F1 From [Sheet1$E3:E]"
    With CreateObject("ADODB.Recordset")
        .Open ("Select Distinct F1 From (" & strSQL & ") Where F1 Is Not Null"), "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
        Sheet1.Range("H3").CopyFromRecordset .DataSource
    End With
End Sub

 

[Nhattanktnn]

Bạn mình thử code dưới xem nhé!

Sub Loc()
    Dim Dic As Object, Key As String, Arr(), Res(1 To 100, 1 To 1)
    Set Dic = CreateObject("scripting.Dictionary")
    Dim k As Long, i As Long
    On Error Resume Next
    With Sheet1
        Arr = .Range("C3:E19").Value
        For i = 1 To UBound(Arr)
            If Arr(i, 1) <> "" And Not Dic.exists(Arr(i, 1)) Then
                k = k + 1
                Dic.Add (Arr(i, 1)), k
                Res(k, 1) = Arr(i, 1)
            End If
            If Arr(i, 3) <> "" And Not Dic.exists(Arr(i, 3)) Then
                k = k + 1
                Dic.Add (Arr(i, 3)), k
                Res(k, 1) = Arr(i, 3)
            End If
        Next i
        .Range("G3:G100").ClearContents
        .Range("G3").Resize(k, 1).Value = Res
    End With
    Set Dic = Nothing
End Sub

Dict hay nhưng viết vậy có lẽ hơi dài dòng:

Sub Loc2()
    Dim Dic As Object, I As Long, J
    Set Dic = CreateObject("scripting.Dictionary")
    With Sheets("Sheet1")
        Arr = .Range("C3:E19").Value
        For I = 1 To UBound(Arr)
            For Each J In Array(1, 3)
                If Arr(I, J) <> "" And Not Dic.exists(Arr(I, J)) Then Dic.Add Arr(I, J), ""
            Next
        Next I
        .Range("G3", "G" & Rows.Count).ClearContents
        .Range("G3").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.keys)
    End With
End Sub

 

[Thóc Sama]

Dict hay nhưng viết vậy có lẽ hơi dài dòng:

Sub Loc2()
    Dim Dic As Object, I As Long, J
    Set Dic = CreateObject("scripting.Dictionary")
    With Sheets("Sheet1")
        Arr = .Range("C3:E19").Value
        For I = 1 To UBound(Arr)
            For Each J In Array(1, 3)
                If Arr(I, J) <> "" And Not Dic.exists(Arr(I, J)) Then Dic.Add Arr(I, J), ""
            Next
        Next I
        .Range("G3", "G" & Rows.Count).ClearContents
        .Range("G3").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.keys)
    End With
End Sub

Cám ơn bác đã xem bài, tôi cũng đang lọ mọ ấy mà!
Code bác trông gọn hẳn