Loại bỏ các cột có giá trị trùng (1 người xem)

[HieuCD]

Mình có một bảng với 15 dòng và 84 cột, mỗi cột có con số khác nhau ở các dòng.
2 cột nếu có 15 con số giống nhau, những con số nầy có thể nằm khác dòng, xem là bị trùng.
nhờ các bạn viết code loại bỏ các cột bị trùng, còn lại là các cột không bị trùng. Cám ơn nhiều

 

[Let'GâuGâu]

Mình có một bảng với 15 dòng và 84 cột, mỗi cột có con số khác nhau ở các dòng.
2 cột nếu có 15 con số giống nhau, những con số nầy có thể nằm khác dòng, xem là bị trùng.
nhờ các bạn viết code loại bỏ các cột bị trùng, còn lại là các cột không bị trùng. Cám ơn nhiều

tôi nghĩ cách đơn giản nhất là
1-sort các cột lại
2-sau đó nối các dòng trong một cột thành chuổi
3-lấy các chuổi đó là key của dictionary
vậy là có thể so sánh được có trùng hay không
=============

 

[HungQuoc49]

Mình có một bảng với 15 dòng và 84 cột, mỗi cột có con số khác nhau ở các dòng.
2 cột nếu có 15 con số giống nhau, những con số nầy có thể nằm khác dòng, xem là bị trùng.
nhờ các bạn viết code loại bỏ các cột bị trùng, còn lại là các cột không bị trùng. Cám ơn nhiều

Bạn kiểm tra code này xem sao

Public Sub LoaiTru()
Dim DL, Chuoi, c As Long, r As Long

DL = Sheet2.Range("A2:CF16")
ReDim Chuoi(1 To UBound(DL, 2))

With CreateObject("system.collections.Arraylist")
For c = 1 To UBound(DL, 2)
For r = 1 To UBound(DL)
.Add DL(r, c)
Next r
.Sort
Chuoi(c) = Join(.ToArray)
.Clear
Next c
End With

With CreateObject("scripting.dictionary")
For c = 1 To UBound(Chuoi)
.Item(Chuoi(c)) = .Item(Chuoi(c)) + 1
Next c

For c = 1 To UBound(Chuoi)
If .Item(Chuoi(c)) > 1 Then
.Remove Chuoi(c)
Else
.Item(Chuoi(c)) = c
End If
Next c

Sheet2.Range("A18").Clear
Sheet2.Range("A18") = Join(.items)
End With
End Sub

 

[concogia]

tôi nghĩ cách đơn giản nhất là
1-sort các cột lại
2-sau đó nối các dòng trong một cột thành chuổi
3-lấy các chuổi đó là key của dictionary
vậy là có thể so sánh được có trùng hay không
=============

Nếu không Sort trên bảng tính cũng như Sort trong mảng thì........có "xử" nó được hông ???
Thân

 

[HieuCD]

Nếu không Sort trên bảng tính cũng như Sort trong mảng thì........có "xử" nó được hông ???
Thân

Làm thế nào cũng được, và trả về trên các cột có 15 dòng là tốt rồi, cám ơn bạn

 

[Ba Tê]

Làm thế nào cũng được, và trả về trên các cột có 15 dòng là tốt rồi, cám ơn bạn

Bạn tự kiểm tra xem có đúng không, nhìn "đám rừng" chóng mặt quá.
Hôm nay GPE "quay quay" nhiều quá.

 

[HieuCD]

Cám ơn các bạn nhiều, nhờ các bạn giúp mà mình đã làm được

 

[Let'GâuGâu]

Nếu không Sort trên bảng tính cũng như Sort trong mảng thì........có "xử" nó được hông ???
Thân

ăn gian tí, hỏng biết có trúng không

Sub test()
Dim arr, tam(1 To 100) As Variant
Dim i, j, k As Long
Dim dic As Object
arr = [a2:cf16]

Set dic = CreateObject("Scripting.Dictionary")

For j = 1 To UBound(arr, 2)
    For i = 1 To UBound(arr)
        tam(arr(i, j)) = arr(i, j)
    Next
    ST = Join(tam, "#")
    If Not dic.exists(ST) Then
        dic.Add ST, ""
    Else
       For i = 1 To UBound(arr)
            arr(i, j) = ""
        Next
    End If
Next

[A19].Resize(15, 83) = arr
End Sub

 

[doveandrose]

ăn gian tí, hỏng biết có trúng không

Sub test()
Dim arr, tam(1 To 100) As Variant
Dim i, j, k As Long
Dim dic As Object
arr = [a2:cf16]

Set dic = CreateObject("Scripting.Dictionary")

For j = 1 To UBound(arr, 2)
    For i = 1 To UBound(arr)
        tam(arr(i, j)) = arr(i, j)
    Next
    ST = Join(tam, "#")
    If Not dic.exists(ST) Then
        dic.Add ST, ""
    Else
       For i = 1 To UBound(arr)
            arr(i, j) = ""
        Next
    End If
Next

[A19].Resize(15, 83) = arr
End Sub

không biết có trúng hông nên muốn xin anh ở trên thử code đó cho bài toán chỉ có 3 cột

 

[HieuCD]

ăn gian tí, hỏng biết có trúng không

Sub test()
Dim arr, tam(1 To 100) As Variant
Dim i, j, k As Long
Dim dic As Object
arr = [a2:cf16]

Set dic = CreateObject("Scripting.Dictionary")

For j = 1 To UBound(arr, 2)
    For i = 1 To UBound(arr)
        tam(arr(i, j)) = arr(i, j)
    Next
    ST = Join(tam, "#")
    If Not dic.exists(ST) Then
        dic.Add ST, ""
    Else
       For i = 1 To UBound(arr)
            arr(i, j) = ""
        Next
    End If
Next

[A19].Resize(15, 83) = arr
End Sub

code chỉ ra 9 cột thiếu 26 cột

 

[doveandrose]

code chỉ ra 9 cột thiếu 26 cột

mình biết ngay sẽ có khiếu nại mà . hi hi
các số thật có giống trong bài #1 không hay là chứa cả chữ , tào lao bí đao nữa vậy ?

 

[HieuCD]

mình biết ngay sẽ có khiếu nại mà . hi hi
các số thật có giống trong bài #1 không hay là chứa cả chữ , tào lao bí đao nữa vậy ?

đó là số thật chỉ khác địa chỉ thôi, đưa về về đầu sheet cho dể thấy

 

[HungQuoc49]

code chỉ ra 9 cột thiếu 26 cột

Bạn có thể cho danh sách số thứ tự 35 cột đạt yêu cầu hay không, vì chạy thử thấy có 33 cột đạt yêu cầu. Không biết lệch chỗ nào

 

[HungQuoc49]

ăn gian tí, hỏng biết có trúng không

Sub test()
Dim arr, tam(1 To 100) As Variant
Dim i, j, k As Long
Dim dic As Object
arr = [a2:cf16]

Set dic = CreateObject("Scripting.Dictionary")

For j = 1 To UBound(arr, 2)
    For i = 1 To UBound(arr)
        tam(arr(i, j)) = arr(i, j)
    Next
    ST = Join(tam, "#")
    If Not dic.exists(ST) Then
        dic.Add ST, ""
    Else
       For i = 1 To UBound(arr)
            arr(i, j) = ""
        Next
    End If
Next

[A19].Resize(15, 83) = arr
End Sub

Hình như chỗ hàm join() phải thêm replace để xóa hết khoảng trắng mới ăn tiền.

 

[Let'GâuGâu]

không biết có trúng hông nên muốn xin anh ở trên thử code đó cho bài toán chỉ có 3 cột

hehehhe........quên xóa mảng tạm
lúc đầu nhìn sơ qua, thấy trong mỗi cột không có trùng, bì giờ nhìn kết quả của bác ba thấy có trùng......hehehhe..........thua vậy

 

[HieuCD]

Bạn có thể cho danh sách số thứ tự 35 cột đạt yêu cầu hay không, vì chạy thử thấy có 33 cột đạt yêu cầu. Không biết lệch chỗ nào

mỗi cách làm ra cột khác nhau, mình chạy code của bạn, sao đó tìm cách làm gần giống nhất thì thấy thiếu cột 70 và 71
[TABLE="width: 25"]
[TR]
[TD="class: xl63, width: 25"]41 42 51 52 53 56 57 58 59 60 61 62 63 64 65 66 67 68 69 80 81 82 83 84 54 72 73 74 75 76 77 78 79[/TD]
[/TR]
[/TABLE]

 

[HieuCD]

Bạn có thể cho danh sách số thứ tự 35 cột đạt yêu cầu hay không, vì chạy thử thấy có 33 cột đạt yêu cầu. Không biết lệch chỗ nào

mình dùng code của bạn Let'GâuGâu ra 35 cột, và dùng code của bạn và thay đổi 1 chút cũng ra 35 cột
[TABLE="width: 814"]
[TR]
[TD="class: xl65, width: 26"]1[/TD]
[TD="class: xl65, width: 23"]2[/TD]
[TD="class: xl65, width: 23"]3[/TD]
[TD="class: xl65, width: 23"]4[/TD]
[TD="class: xl65, width: 23"]5[/TD]
[TD="class: xl65, width: 23"]6[/TD]
[TD="class: xl65, width: 23"]7[/TD]
[TD="class: xl65, width: 23"]8[/TD]
[TD="class: xl65, width: 23"]9[/TD]
[TD="class: xl65, width: 23"]10[/TD]
[TD="class: xl65, width: 28"]20[/TD]
[TD="class: xl65, width: 23"]30[/TD]
[TD="class: xl65, width: 23"]40[/TD]
[TD="class: xl65, width: 23"]50[/TD]
[TD="class: xl65, width: 23"]52[/TD]
[TD="class: xl65, width: 23"]53[/TD]
[TD="class: xl65, width: 23"]56[/TD]
[TD="class: xl65, width: 23"]57[/TD]
[TD="class: xl65, width: 23"]58[/TD]
[TD="class: xl65, width: 23"]59[/TD]
[TD="class: xl65, width: 23"]60[/TD]
[TD="class: xl65, width: 23"]61[/TD]
[TD="class: xl65, width: 23"]62[/TD]
[TD="class: xl65, width: 23"]63[/TD]
[TD="class: xl65, width: 23"]64[/TD]
[TD="class: xl65, width: 23"]65[/TD]
[TD="class: xl65, width: 23"]66[/TD]
[TD="class: xl65, width: 23"]67[/TD]
[TD="class: xl65, width: 23"]68[/TD]
[TD="class: xl65, width: 23"]69[/TD]
[TD="class: xl65, width: 24"]80[/TD]
[TD="class: xl65, width: 23"]81[/TD]
[TD="class: xl65, width: 23"]82[/TD]
[TD="class: xl65, width: 23"]83[/TD]
[TD="class: xl65, width: 23"]84
[/TD]
[/TR]
[/TABLE]
Sub kt()
Dim DL, Chuoi, c As Long, r As Long, dic As Object, cot As Integer, i As Integer, tam
DL = Range("A2:CF16")
ReDim Chuoi(1 To UBound(DL, 2))
Set dic = CreateObject("scripting.dictionary")
With CreateObject("system.collections.Arraylist")
On Error Resume Next
cot = 0
For c = 1 To UBound(DL, 2)
For r = 1 To UBound(DL)
.Add DL(r, c)
Next r
.Sort
Chuoi(c) = Join(.ToArray)
.Clear
dic.Add Chuoi(c), ""
tam = dic.keys()(cot)
If Chuoi(c) = tam Then
cot = cot + 1
For i = 1 To 15
Cells(i + 18, cot) = DL(i, c)
Next
Cells(35, cot) = c
End If
Next c
End With
End Sub

 

[HungQuoc49]

mỗi cách làm ra cột khác nhau, mình chạy code của bạn, sao đó tìm cách làm gần giống nhất thì thấy thiếu cột 70 và 71
[TABLE="width: 25"]
[TR]
[TD="class: xl63, width: 25"]41 42 51 52 53 56 57 58 59 60 61 62 63 64 65 66 67 68 69 80 81 82 83 84 54 72 73 74 75 76 77 78 79
[/TD]
[/TR]
[/TABLE]

Cột 70 và cột 1; cột 71 và cột 2 là giống nhau thì phải, bạn thử kiểm tra xem sao

 

[doveandrose]

hehehhe........quên xóa mảng tạm
lúc đầu nhìn sơ qua, thấy trong mỗi cột không có trùng, bì giờ nhìn kết quả của bác ba thấy có trùng......hehehhe..........thua vậy

thua sao được . Tôi thích cách nghĩ của "em" Let Gâu Gâu nên tôi phải chắp cánh cho diều bay .

Public Sub thàyLetGauGau()
Dim arr, r As Long, c As Long, tmp, dic As Object, n As Long, dArr, i As Long
arr = Sheet2.Range("A2").Resize(15, 84).Value
Set dic = CreateObject("Scripting.Dictionary")
For c = 1 To UBound(arr, 2) Step 1
    ReDim tmp(1 To 100)
    For r = 1 To UBound(arr) Step 1
        tmp(arr(r, c)) = arr(r, c)
    Next
    tmp = WorksheetFunction.Trim(Join(tmp, " "))
    If Not dic.exists(tmp) Then
        dic(tmp) = 1
        n = n + 1
        If n = 1 Then ReDim dArr(1 To UBound(arr), 1 To 1) Else ReDim Preserve dArr(1 To UBound(arr), 1 To n)
        tmp = Split(tmp)
        For i = 1 To UBound(dArr) Step 1
            dArr(i, n) = tmp(i - 1)
        Next
    End If
Next
Sheet2.Range("A20").Resize(UBound(dArr) + 100, UBound(dArr, 2) + 100).ClearContents
Sheet2.Range("A20").Resize(UBound(dArr), UBound(dArr, 2)).Value = dArr
End Sub

 

[HieuCD]

thua sao được . Tôi thích cách nghĩ của "em" Let Gâu Gâu nên tôi phải chắp cánh cho diều bay .

Public Sub thàyLetGauGau()
Dim arr, r As Long, c As Long, tmp, dic As Object, n As Long, dArr, i As Long
arr = Sheet2.Range("A2").Resize(15, 84).Value
Set dic = CreateObject("Scripting.Dictionary")
For c = 1 To UBound(arr, 2) Step 1
    ReDim tmp(1 To 100)
    For r = 1 To UBound(arr) Step 1
        tmp(arr(r, c)) = arr(r, c)
    Next
    tmp = WorksheetFunction.Trim(Join(tmp, " "))
    If Not dic.exists(tmp) Then
        dic(tmp) = 1
        n = n + 1
        If n = 1 Then ReDim dArr(1 To UBound(arr), 1 To 1) Else ReDim Preserve dArr(1 To UBound(arr), 1 To n)
        tmp = Split(tmp)
        For i = 1 To UBound(dArr) Step 1
            dArr(i, n) = tmp(i - 1)
        Next
    End If
Next
Sheet2.Range("A20").Resize(UBound(dArr) + 100, UBound(dArr, 2) + 100).ClearContents
Sheet2.Range("A20").Resize(UBound(dArr), UBound(dArr, 2)).Value = dArr
End Sub

Cám ơn bạn nhiều, mình sẽ dùng code của bạn để chạy tập của mình