Mọi người giúp mình cách xoá bỏ dữ liệu trùng trong 1 cột. (4 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
tintam7251 đã viết:
Mình khắc phục lỗi trên như sau, nhờ các bác coi dùm
Mã: 
Sub khong_trung()
On Error Resume Next
Dim dic1 As Object, i As Long, j As Long, arr(), FindNumber As Long, a As Long
Dim Memo(100) As Variant, FindOutArray As Variant
Set dic1 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
Range([B1], [B65536].End(3)).ClearContents
a = 1
With dic1
  For i = 1 To UBound(dk)
   FindOutArray = Filter(SourceArray:=Memo, Match:=dk(i, 1), Include:=True, Compare:=vbBinaryCompare)
   FindNumber = UBound(FindOutArray)
      If dk(i, 1) <> "" Then
         If .exists(dk(i, 1)) Then
              .Remove dk(i, 1)
              Memo(a) = dk(i, 1)
            a = a + 1
         Else
           If FindNumber = -1 Then
               .Add dk(i, 1), dk(i, 1)
           End If
         End If
     End If
    Next
  ReDim arr(1 To .Count, 1 To 1)
     Items = .Items
   For j = 1 To .Count
     arr(j, 1) = Items(j - 1)
   Next
[B1].Resize(.Count, 1) = arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
1. Bạn khai báo thiếu dk, Items
2. Khi cột A không có dữ liệu hoặc chỉ có dữ liệu 1 ô A1 thì bị lỗi
 
Cái bài này nếu chỉ dùng 1 Đít- to & 1 vòng lặp có giải được không ????????? Giải bằng array & cho sử dụng WorksheetFunction
À há!!! xỉn rồi ....té ra hay, hoan hô đám cưới
Híc
 
concogia đã viết:
Cái bài này nếu chỉ dùng 1 Đít- to & 1 vòng lặp có giải được không ????????? Giải bằng array & cho sử dụng WorksheetFunction
À há!!! xỉn rồi ....té ra hay, hoan hô đám cưới
Híc
Nhấp chuột vào đây để mở rộng...
Anh Cò ơi bài này nếu cho dùng worksheetFunction thì em không cần Dic và 1 vòng lập là ra ngay thôi, nhưng anh NDU ép em không cho xài WF mới tức chứ
 
concogia đã viết:
Wa, em trai còn thức, bài giải đó ra sao vậy??
Nhấp chuột vào đây để mở rộng...
Em giải thế này nè, tạm thời không nói đến bẫy lỗi nha. Hoc được vài chiêu của anh nên đem ra múa tùm lum
PHP: 
Sub khong_trung3()
Dim dk1 As Variant, dk2 As Range, arr1(), arr2(), i As Long, j As Long
dk1 = Range([a1], [a65536].End(3)).Value
Set dk2 = Range([a1], [a65536].End(3))
ReDim arr1(1 To UBound(dk1), 1 To 2)
For i = 1 To UBound(dk1)
   arr1(i, 1) = Application.CountIf(dk2, dk1(i, 1))
   arr1(i, 2) = dk1(i, 1)
   If arr1(i, 1) = 1 Then
      j = j + 1
      ReDim Preserve arr2(1 To j)
      arr2(j) = arr1(i, 2)
   End If
Next
If j Then [B1].Resize(j, 1) = Application.Transpose(arr2)
End Sub
 
quanghai1969 đã viết:
Em giải thế này nè, tạm thời không nói đến bẫy lỗi nha. Hoc được vài chiêu của anh nên đem ra múa tùm lum
PHP: 
Sub khong_trung3()
Dim dk1 As Variant, dk2 As Range, arr1(), arr2(), i As Long, j As Long
dk1 = Range([a1], [a65536].End(3)).Value
Set dk2 = Range([a1], [a65536].End(3))
ReDim arr1(1 To UBound(dk1), 1 To 2)
For i = 1 To UBound(dk1)
   arr1(i, 1) = Application.CountIf(dk2, dk1(i, 1))
   arr1(i, 2) = dk1(i, 1)
   If arr1(i, 1) = 1 Then
      j = j + 1
      ReDim Preserve arr2(1 To j)
      arr2(j) = arr1(i, 2)
   End If
Next
If j Then [B1].Resize(j, 1) = Application.Transpose(arr2)
End Sub
Nhấp chuột vào đây để mở rộng...
Thế bi giờ hông chơi worksheetFunction thì sao ?????
Híc, hihihi
Cái này là vui chơi học tập trong thời gian rảnh, chứ giải quyết bài này như em viết là quá ok rồi. Híc
 
concogia đã viết:
Thế bi giờ hông chơi worksheetFunction thì sao ?????
Híc, hihihi
Cái này là vui chơi học tập trong thời gian rảnh, chứ giải quyết bài này như em viết là quá ok rồi. Híc
Nhấp chuột vào đây để mở rộng...
Nếu không chơi WF thì phải dùng dic và mảng rồi. em có giải mấy bài phía trên mà anh. Anh có cao kiến gì không? Em xài hết đồ nghề rồi
 
Thôi mai tính tiếp anh ơi. Nếu đã có chỉ điểm như vậy nhất định em sẽ làm được mà.
 
ndu96081631 đã viết:
Thì anh Cò làm thử đi... Đố hoài
Ẹc... Ẹc... Cũng hay à nha!
Nhấp chuột vào đây để mở rộng...
Cái này hổng phải đố nha Thầy, chỉ là ở không quá sinh ra như thế
Híc, xó-zì Thầy ndu & bạn Quang Hải, hôm qua xỉn quá, lo tránh cái thằng Countif thôi, cuối cùng vẫn vướng thằng Transpose. "Bố khỉ"
Mã: 
Public Sub HongPhai()
    Dim Vung, I, d, DoTim
    Set d = CreateObject("scripting.dictionary")
    Vung = Range([a1], [A1000].End(xlUp))
    For I = 1 To UBound(Vung)
        If Vung(I, 1) <> "" Then
            If Not d.exists(Vung(I, 1)) Then
                If InStr(DoTim, Vung(I, 1)) = 0 Then
                    d.Add Vung(I, 1), ""
                 End If
             Else
                    d.Remove Vung(I, 1)
                    DoTim = DoTim & " " & Vung(I, 1)
             End If
        End If
    Next I
        [B1:b1000].ClearContents
        If d.Count > 0 Then
            [B1].Resize(d.Count) = Application.WorksheetFunction.Transpose(d.keys)
        Else
            MsgBox ("Trung ca bay, hong co em nao duy nhat")
        End If
End Sub
Chỉ làm được 1 Đít & 1 vòng lặp, phải chi cho kết quả theo hàng ngang thì được " chăm phần chăm", hihi
 
concogia đã viết:
Cái này hổng phải đố nha Thầy, chỉ là ở không quá sinh ra như thế
Híc, xó-zì Thầy ndu & bạn Quang Hải, hôm qua xỉn quá, lo tránh cái thằng Countif thôi, cuối cùng vẫn vướng thằng Transpose. "Bố khỉ"
Nhấp chuột vào đây để mở rộng...

Hổng biết anh còn nhớ giải thuật hàm Draw do bạn siwtom làm tại đây không:
http://www.giaiphapexcel.com/forum/...thức-tính-một-dạng-Tổ-hợp&p=408551#post408551
Em đang mường tượng phương pháp hoán vị kiểu như trên có thể xài được trong bài này đấy! Rất có thể chỉ dùng 1 vòng lập và không cần TRANSPOSE gì cả
Để nghiên cứu xem
 
ndu96081631 đã viết:
Hổng biết anh còn nhớ giải thuật hàm Draw do bạn siwtom làm tại đây không:
http://www.giaiphapexcel.com/forum/...thức-tính-một-dạng-Tổ-hợp&p=408551#post408551
Em đang mường tượng phương pháp hoán vị kiểu như trên có thể xài được trong bài này đấy! Rất có thể chỉ dùng 1 vòng lập và không cần TRANSPOSE gì cả
Để nghiên cứu xem
Nhấp chuột vào đây để mở rộng...

Như đã nói ở trên, ta dùng phương pháp hoán vị để xử lý bài này như sau:
PHP: 
Sub Test()
  Dim sArray, Arr(), Item
  Dim tmp As String
  Dim n As Long, lMark As Long
  sArray = Range("A1:A10000").Value
  Range("B1:B10000").ClearContents
  ReDim Arr(1 To UBound(sArray, 1), 1 To 1)
  With CreateObject("Scripting.Dictionary")
    For Each Item In sArray
      If Len(CStr(Item)) Then
        tmp = CStr(Item)
        If Not .Exists(tmp) Then
          n = n + 1
          .Add tmp, n
          Arr(n, 1) = tmp
        ElseIf .Item(tmp) > 0 Then
          lMark = .Item(tmp)
          .Item(tmp) = 0
          If lMark < n Then
            .Item(Arr(n, 1)) = lMark
            Arr(lMark, 1) = Arr(n, 1)
          End If
          n = n - 1
        End If
      End If
    Next
    If .Count Then
      If n Then
        Range("B1").Resize(n).Value = Arr
        MsgBox n & " phan tu duoc tim thay"
      Else
        MsgBox "Tat ca du lieu deu trung"
      End If
    Else
      MsgBox "Không tìm thay du lieu nao"
    End If
  End With
End Sub
Chỉ 1 vòng lập và cũng không dùng TRANSPOSE luôn
Nhờ các bạn kiểm tra giúp nhé
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Như đã nói ở trên, ta dùng phương pháp hoán vị để xử lý bài này như sau:
PHP: 
Sub Test()
  Dim sArray, Arr(), Item
  Dim tmp As String
  Dim n As Long, lMark As Long
  sArray = Range("A1:A10000").Value
  Range("B1:B10000").ClearContents
  ReDim Arr(1 To UBound(sArray, 1), 1 To 1)
  With CreateObject("Scripting.Dictionary")
    For Each Item In sArray
      If Len(CStr(Item)) Then
        tmp = CStr(Item)
        If Not .Exists(tmp) Then
          n = n + 1
          .Add tmp, n
          Arr(n, 1) = tmp
        ElseIf .Item(tmp) > 0 Then
          lMark = .Item(tmp)
          .Item(tmp) = 0
          If lMark < n Then
            .Item(Arr(n, 1)) = lMark
            Arr(lMark, 1) = Arr(n, 1)
          End If
          n = n - 1
        End If
      End If
    Next
    If .Count Then
      If n Then
        Range("B1").Resize(n).Value = Arr
        MsgBox n & " phan tu duoc tim thay"
      Else
        MsgBox "Tat ca du lieu deu trung"
      End If
    Else
      MsgBox "Không tìm thay du lieu nao"
    End If
  End With
End Sub
Chỉ 1 vòng lập và cũng không dùng TRANSPOSE luôn
Nhờ các bạn kiểm tra giúp nhé
Nhấp chuột vào đây để mở rộng...

Em đọc và ứng dụng được bài này của anh chắc mất 1 tháng. Sao nó trừu tượng quá.
 
quanghai1969 đã viết:
Em đọc và ứng dụng được bài này của anh chắc mất 1 tháng. Sao nó trừu tượng quá.
Nhấp chuột vào đây để mở rộng...
Thấy dài thế chứ giái thuật của nó dễ ợt! Đại khái thế này:
- Giả sử lúc đầu ta add vào được 5 giá trị (chưa có cái nào trùng) là a, b, c, d, e (lúc này n =5). Cùng lúc cho luôn vào mảng 2 chiều Arr
- Đến lần lập thứ 6, giá trị nhận được là c, ta phát hiện nó trùng ở vị trí thứ 3
- Vậy ta sẽ hoán vị, lấy thằng thứ 5 đưa lên thứ 3 và ngược lại. Xong, giảm n xuống 1 đơn vị để n = 4 (để "liệng" cái thằng trùng đi)
Ẹc... Ẹc... chỉ thế thôi (đương nhiên để ý thêm vài chổ ĐÁNH DẤU trong Item của Dic)
 
ndu96081631 đã viết:
Thấy dài thế chứ giái thuật của nó dễ ợt! Đại khái thế này:
- Giả sử lúc đầu ta add vào được 5 giá trị (chưa có cái nào trùng) là a, b, c, d, e (lúc này n =5). Cùng lúc cho luôn vào mảng 2 chiều Arr
- Đến lần lập thứ 6, giá trị nhận được là c, ta phát hiện nó trùng ở vị trí thứ 3
- Vậy ta sẽ hoán vị, lấy thằng thứ 5 đưa lên thứ 3 và ngược lại. Xong, giảm n xuống 1 đơn vị để n = 4 (để "liệng" cái thằng trùng đi)
Ẹc... Ẹc... chỉ thế thôi (đương nhiên để ý thêm vài chổ ĐÁNH DẤU trong Item của Dic)
Nhấp chuột vào đây để mở rộng...
Chỉ hiểu và làm được thế này thôi, xin được chỉ những chỗ chưa hợp lý.
PHP: 
Public Sub GPE()
Dim Rng(), Dic As Object, I As Long, Arr(), n As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    .[E1:E10000].ClearContents
    Rng = .[A1:A10000].Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 1)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 1) <> "" Then
            If Not Dic.Exists(Rng(I, 1)) Then
                n = n + 1
                Dic.Add Rng(I, 1), n
                Arr(n, 1) = Rng(I, 1)
            Else
                K = Dic.Item(Rng(I, 1))
                Arr(K, 1) = Arr(n, 1)
                n = n - 1
            End If
        End If
    Next I
        If n Then .[E1].Resize(n).Value = Arr
End With
    Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Ba Tê đã viết:
Chỉ hiểu và làm được thế này thôi, xin được chỉ những chỗ chưa hợp lý.
PHP: 
Public Sub GPE()
Dim Rng(), Dic As Object, I As Long, Arr(), n As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    .[E1:E10000].ClearContents
    Rng = .[A1:A10000].Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 1)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 1) <> "" Then
            If Not Dic.Exists(Rng(I, 1)) Then
                n = n + 1
                Dic.Add Rng(I, 1), n
                Arr(n, 1) = Rng(I, 1)
            Else
                K = Dic.Item(Rng(I, 1))
                Arr(K, 1) = Arr(n, 1)
                n = n - 1
            End If
        End If
    Next I
        If n Then .[E1].Resize(n).Value = Arr
End With
    Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Code của anh BaTê chạy không chuẩn so với yêu cầu rồi anh ơi.
 
quanghai1969 đã viết:
Code của anh BaTê chạy không chuẩn so với yêu cầu rồi anh ơi.
Nhấp chuột vào đây để mở rộng...
Thêm một dòng nữa xem sao, đang mò mà!
PHP: 
Public Sub GPE()
Dim Rng(), Dic As Object, I As Long, Arr(), n As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    .[E1:E10000].ClearContents
    Rng = .[A1:A10000].Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 1)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 1) <> "" Then
            If Not Dic.Exists(Rng(I, 1)) Then
                n = n + 1
                Dic.Add Rng(I, 1), n
                Arr(n, 1) = Rng(I, 1)
            Else
                K = Dic.Item(Rng(I, 1))
                Dic.Item(Arr(n, 1)) = K ''----------------"Hinh nhu Thieu dong nay"
                Arr(K, 1) = Arr(n, 1)
                n = n - 1
            End If
        End If
    Next I
        If n Then .[E1].Resize(n).Value = Arr
End With
    Set Dic = Nothing
End Sub
Ẹc.Ẹc...
 
Lần chỉnh sửa cuối:
Ba Tê đã viết:
Thêm một dòng nữa xem sao, đang mò mà!
PHP: 
Public Sub GPE()
Dim Rng(), Dic As Object, I As Long, Arr(), n As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    .[E1:E10000].ClearContents
    Rng = .[A1:A10000].Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 1)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 1) <> "" Then
            If Not Dic.Exists(Rng(I, 1)) Then
                n = n + 1
                Dic.Add Rng(I, 1), n
                Arr(n, 1) = Rng(I, 1)
            Else
                K = Dic.Item(Rng(I, 1))
                Dic.Item(Arr(n, 1)) = K ''----------------"Hinh nhu Thieu dong nay"
                Arr(K, 1) = Arr(n, 1)
                n = n - 1
            End If
        End If
    Next I
        If n Then .[E1].Resize(n).Value = Arr
End With
    Set Dic = Nothing
End Sub
Ẹc.Ẹc...
Nhấp chuột vào đây để mở rộng...
Cũng vậy anh ơi, em cũng đang nhức đầu với cái này.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025 (3 người xem)
Trả lời
1
Đọc
6
Hoàng Tuấn 868
H
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table (2 người xem)
Trả lời
3
Đọc
131
Hoàng Tuấn 868
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
346
Đọc
31K
Vandat1607
V
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
15
Đọc
243
Hoangkhang01213
Hoangkhang01213
M
Xin giúp đỡ làm công thức điều kiện
Trả lời
2
Đọc
126
Hoangkhang01213
Hoangkhang01213
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
4
Đọc
91
tigertiger
tigertiger
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt (1 người xem)
Trả lời
4
Đọc
174
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module. (1 người xem)
Trả lời
8
Đọc
295
huhumalu
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
167
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
22
Đọc
568
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
146
lamvu0677
L
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
805
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
240
Hoàng Tuấn 868
H
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
0
Đọc
153
nguyendang95
N
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom