Mọi người giúp mình cách xoá bỏ dữ liệu trùng trong 1 cột. (3 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)
H

hungảu

Thành viên mới
Tham gia
13/1/09
Bài viết
5
Được thích
0
Mọi người giúp mình với tìm đang gặp rắc rối với vấn đề này tìm hiểu mấy ngày rồi mà không ra nên nhờ các bạn ở giải pháp excel giúp đỡ.%#^#$
dữ liệu mình ví dụ như sau:

A
B
C
A
----> sau khi lọc và xóa
B
C
sau khi lọc chỉ còn những dữ liệu không trùng thôi, xóa các dữ liệu bị trùng. Dữ liệu trên 1 cột thôi các bạn nha. Mong các bạn giúp đỡ !!$@!!
 
Bạn dùng hàm countif() tại cột bên cạnh để kiểm tra em nào xuất hiện nhiều hơn 1 lần, sau đó dùng autofilter xoá
 
quanghai1969 đã viết:
Bạn dùng hàm countif() tại cột bên cạnh để kiểm tra em nào xuất hiện nhiều hơn 1 lần, sau đó dùng autofilter xoá
Nhấp chuột vào đây để mở rộng...

Quang Hài làm thử bài này bằng VBA xem!
Cũng khá hay nếu như có thể giải quyết được với ít lần lập nhất (không dùng WorksheetFunction để kiểm tra nha)
Ẹc... Ẹc...
 
cảm ơn bạn. nhưng nếu thế mình có thể dùng "remove duplicates" để xóa những dữ liệu trùng. ý mình là xóa luôn những cái bị trùng còn cái không trùng thôi.

A
B
C
A
----> sau khi lọc và xóa
B
C

BạN GIúP MìNH NHA!%#^#$
 
hungau đã viết:
cảm ơn bạn. nhưng nếu thế mình có thể dùng "remove duplicates" để xóa những dữ liệu trùng. ý mình là xóa luôn những cái bị trùng còn cái không trùng thôi.

A
B
C
A
----> sau khi lọc và xóa
B
C

BạN GIúP MìNH NHA!%#^#$
Nhấp chuột vào đây để mở rộng...

Dùng countif() nếu lớn hơn hoặc = 2 thì xóa đi, thì nó ra như Kết qủa bạn muốn mà!
 
hungau đã viết:
cảm ơn bạn. nhưng nếu thế mình có thể dùng "remove duplicates" để xóa những dữ liệu trùng. ý mình là xóa luôn những cái bị trùng còn cái không trùng thôi.

A
B
C
A
----> sau khi lọc và xóa
B
C

BạN GIúP MìNH NHA!%#^#$
Nhấp chuột vào đây để mở rộng...
Bạn có cố tìm hiểu những gì mình diễn tả chưa?
1. Dùng hàm countif() để đếm số lần xuất hiện của dữ liệu
2. Dùng autofilter lọc theo dk khác 1
3. Xoá cả dòng hay xoá thế nào đó tuỳ bạn

... Buồn
 
ok, mình thử và được rồi bạn. cảm ơn bạn nha!
 
ndu96081631 đã viết:
Quang Hài làm thử bài này bằng VBA xem!
Cũng khá hay nếu như có thể giải quyết được với ít lần lập nhất (không dùng WorksheetFunction để kiểm tra nha)
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...
Cũng hơi khó đối với khả năng của em nhưng cố hết sức để anh thấy đàn em của anh tiến bộ hơn trước. Góp ý cho em nha.
PHP: 
Sub khong_trung()
Dim dic1 As Object, dic2 As Object, i
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
With dic1
   For i = 1 To UBound(dk)
      If Not .exists(dk(i, 1)) Then
      .Add dk(i, 1), ""
      Else
         If Not dic2.exists(dk(i, 1)) Then dic2.Add dk(i, 1), ""
      End If
   Next
   .RemoveAll
   For i = 1 To UBound(dk)
      If Not dic2.exists(dk(i, 1)) Then .Add dk(i, 1), ""
   Next
   [b1].Resize(.Count, 1) = Application.Transpose(.keys)
End With
End Sub
 
Lần chỉnh sửa cuối:
hungau đã viết:
Mọi người giúp mình với tìm đang gặp rắc rối với vấn đề này tìm hiểu mấy ngày rồi mà không ra nên nhờ các bạn ở giải pháp excel giúp đỡ.%#^#$
dữ liệu mình ví dụ như sau:

A
B
C
A
----> sau khi lọc và xóa
B
C
sau khi lọc chỉ còn những dữ liệu không trùng thôi, xóa các dữ liệu bị trùng. Dữ liệu trên 1 cột thôi các bạn nha. Mong các bạn giúp đỡ !!$@!!
Nhấp chuột vào đây để mở rộng...
đây là bài toán lọc và rút trích tại chỗ.
 
quanghai1969 đã viết:
Cũng hơi khó đối với khả năng của em nhưng cố hết sức để anh thấy đàn em của anh tiến bộ hơn trước. Góp ý cho em nha.
PHP: 
Sub khong_trung()
Dim dic1 As Object, dic2 As Object, i
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
With dic1
   For i = 1 To UBound(dk)
      If Not .exists(dk(i, 1)) Then
      .Add dk(i, 1), ""
      Else
         If Not dic2.exists(dk(i, 1)) Then dic2.Add dk(i, 1), ""
      End If
   Next
   .RemoveAll
   For i = 1 To UBound(dk)
      If Not dic2.exists(dk(i, 1)) Then .Add dk(i, 1), ""
   Next
   [b1].Resize(.Count, 1) = Application.Transpose(.keys)
End With
End Sub
Nhấp chuột vào đây để mở rộng...
- Thứ nhất: Phạm luật vì dùng WorksheetFunction (như tôi nói ở trên) nha
- Thừ hai: Chưa bẫy lỗi (chẳng hạn toàn bộ dữ liệu đều trùng hoặc không có dữ liệu nào)
- Thứ ba: Dùng 1 Dictionary cũng được vậy! Chẳng hạn thế này:
Mã: 
 If Not .exists(dk(i, 1)) Then
   .Add dk(i, 1), [COLOR=#ff0000][B]1[/B][/COLOR]
  Else
   [COLOR=#ff0000][B].Item(dk(i, 1)) = .Item(dk(i, 1)) + 1[/B][/COLOR]
End If
tiếp theo ta sẽ xét thằng Key nào có Item = 1 thì lấy
vân vân....
Ẹc... Ẹc... Cố lên!
(Chủ nhật chẳng có quái gì để làm nên phải bày chuyện ra cho đở buồn --=0)
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
- Thứ nhất: Phạm luật vì dùng WorksheetFunction (như tôi nói ở trên) nha
- Thừ hai: Chưa bẫy lỗi (chẳng hạn toàn bộ dữ liệu đều trùng hoặc không có dữ liệu nào)
- Thứ ba: Dùng 1 Dictionary cũng được vậy! Chẳng hạn thế này:
Mã: 
 If Not .exists(dk(i, 1)) Then
   .Add dk(i, 1), [COLOR=#ff0000][B]1[/B][/COLOR]
  Else
   [COLOR=#ff0000][B].Item(dk(i, 1)) = .Item(dk(i, 1)) + 1[/B][/COLOR]
End If
tiếp theo ta sẽ xét thằng Key nào có Item = 1 thì lấy
vân vân....
Ẹc... Ẹc... Cố lên!
(Chủ nhật chẳng có quái gì để làm nên phải bày chuyện ra cho đở buồn --=0)
Nhấp chuột vào đây để mở rộng...
Em giải thế này anh xem coi tạm được chưa.

PHP: 
Sub khong_trung()
Dim dic1 As Object, i, j
Set dic1 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
ReDim arr(1 To UBound(dk), 1 To 1)
With dic1
   For i = 1 To UBound(dk)
      If Not .exists(dk(i, 1)) Then
         .Add dk(i, 1), 1
      Else
         .Item(dk(i, 1)) = .Item(dk(i, 1)) + 1
      End If
   Next
   Items = .Items:   keys = .keys
   For i = 0 To UBound(Items)
      If Items(i) = 1 Then
         j = j + 1
         arr(j, 1) = keys(i)
      End If
   Next
End With
If j Then [b1].Resize(j, 1) = arr
End Sub
 
quanghai1969 đã viết:
Em giải thế này anh xem coi tạm được chưa.

PHP: 
Sub khong_trung()
Dim dic1 As Object, i, j
Set dic1 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
ReDim arr(1 To UBound(dk), 1 To 1)
With dic1
   For i = 1 To UBound(dk)
      If Not .exists(dk(i, 1)) Then
         .Add dk(i, 1), 1
      Else
         .Item(dk(i, 1)) = .Item(dk(i, 1)) + 1
      End If
   Next
   Items = .Items:   keys = .keys
   For i = 0 To UBound(Items)
      If Items(i) = 1 Then
         j = j + 1
         arr(j, 1) = keys(i)
      End If
   Next
End With
If j Then [b1].Resize(j, 1) = arr
End Sub
Nhấp chuột vào đây để mở rộng...
Gần được rồi đấy
Giờ Quang Hải thử với dữ liệu thế này nhé:
A1 = "A"
A2 = "B"
A3 rổng
A4 = "A"
A5 = "B"
A6 = "C"
Xong, chạy code xem thế nào!
Ngoài ra, nếu xóa hết cột A rồi chạy code thì... sao?
Ngoài ra, liệu có thể dùng phép tính nào đó để ReDim vừa đủ cho mảng Arr không? (ở trên ReDim quá thừa rồi...)
Ẹc... Ẹc...
 
ndu96081631 đã viết:
Gần được rồi đấy
Giờ Quang Hải thử với dữ liệu thế này nhé:
A1 = "A"
A2 = "B"
A3 rổng
A4 = "A"
A5 = "B"
A6 = "C"
Xong, chạy code xem thế nào!
Ngoài ra, nếu xóa hết cột A rồi chạy code thì... sao?
Ngoài ra, liệu có thể dùng phép tính nào đó để ReDim vừa đủ cho mảng Arr không? (ở trên ReDim quá thừa rồi...)
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

Em sắp bị nocked out rồi, em chỉ giảm tí xíu chứ không thể làm cho vừa vặn được anh ơi
PHP: 
Sub khong_trung()
Dim dic1 As Object, i, j, arr()
Set dic1 = CreateObject("scripting.dictionary")
dk = UsedRange.Value
With dic1
   For i = 1 To UBound(dk)
      If dk(i, 1) <> "" Then
         If Not .exists(dk(i, 1)) Then
            .Add dk(i, 1), 1
         Else
            .Item(dk(i, 1)) = .Item(dk(i, 1)) + 1
         End If
      End If
   Next
   items = .items:   keys = .keys
   ReDim arr(1 To UBound(items), 1 To 1)
   For i = 0 To UBound(items)
      If items(i) = 1 Then
         j = j + 1
         arr(j, 1) = keys(i)
      End If
   Next
End With
If j Then [b1].Resize(j, 1) = arr
End Sub
 
quanghai1969 đã viết:
Em sắp bị nocked out rồi, em chỉ giảm tí xíu chứ không thể làm cho vừa vặn được anh ơi
PHP: 
Sub khong_trung()
Dim dic1 As Object, i, j, arr()
Set dic1 = CreateObject("scripting.dictionary")
dk = UsedRange.Value
With dic1
   For i = 1 To UBound(dk)
      If dk(i, 1) <> "" Then
         If Not .exists(dk(i, 1)) Then
            .Add dk(i, 1), 1
         Else
            .Item(dk(i, 1)) = .Item(dk(i, 1)) + 1
         End If
      End If
   Next
   items = .items:   keys = .keys
   ReDim arr(1 To UBound(items), 1 To 1)
   For i = 0 To UBound(items)
      If items(i) = 1 Then
         j = j + 1
         arr(j, 1) = keys(i)
      End If
   Next
End With
If j Then [b1].Resize(j, 1) = arr
End Sub
Nhấp chuột vào đây để mở rộng...
ReDim thế này là vừa đủ nè:
Mã: 
Sub Test()
  Dim sArray, Arr(), Keys, Key
  Dim tmp As String, Item
  Dim i As Long, n As Long
  sArray = Range("A1:A10000").Value
  Range("B1:B10000").ClearContents
  With CreateObject("Scripting.Dictionary")
    For Each Item In sArray
      If Len(CStr(Item)) Then
        tmp = CStr(Item)
        If Not .Exists(tmp) Then
          .Add tmp, 1
        Else
          [COLOR=#ff0000][B]If .Item(tmp) = 1 Then n = n + 1[/B][/COLOR]
          .Item(tmp) = .Item(tmp) + 1
        End If
      End If
    Next
    If .Count Then
      If .Count - n Then
        Keys = .Keys: [COLOR=#ff0000][B]n = 0[/B][/COLOR]
        [COLOR=#ff0000][B]ReDim Arr(1 To .Count - n, 1 To 1)[/B][/COLOR]
        For Each Key In Keys
          If .Item(Key) = 1 Then
            n = n + 1
            Arr(n, 1) = Key
          End If
        Next
        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ú ý mấy chổ màu đỏ nha!
(Nhớ khai báo biến đầy đủ chứ đồng chí... Ngoài ra cũng đừng dùng UsedRange ---> Chạy lần 2 nó chơi luôn dữ liệu mình mới lọc à)
 
Lần chỉnh sửa cuối:
Xin phép bạn quanghai1969, mình chỉnh lại chút cho vừa nhé!
Mã: 
Sub khong_trung()
Dim dic1 As Object, i As Long, j As Long, arr()
Set dic1 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
Range([B1], [B65536].End(3)).ClearContents
With dic1
   For i = 1 To UBound(dk)
      If dk(i, 1) <> "" Then
         If Not .exists(dk(i, 1)) Then
            .Add dk(i, 1), dk(i, 1)
         Else
            .Remove dk(i, 1)
         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
 
tintam7251 đã viết:
Xin phép bạn quanghai1969, mình chỉnh lại chút cho vừa nhé!
Mã: 
Sub khong_trung()
Dim dic1 As Object, i As Long, j As Long, arr()
Set dic1 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
Range([B1], [B65536].End(3)).ClearContents
With dic1
   For i = 1 To UBound(dk)
      If dk(i, 1) <> "" Then
         If Not .exists(dk(i, 1)) Then
            .Add dk(i, 1), dk(i, 1)
         Else
            .Remove dk(i, 1)
         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...
Giờ bạn thử với dữ liệu thế này nha:
- Cell A1, A4, A7 = "A"
- Cell A2, A5, A8 = "B"
- Cell A3, A6, A9 = "C"
- Cell A10 = "D"
Chạy code của bạn xem nó ra cái gì?
Kết quả đúng sẽ là duy nhất 1 chữ "D" thôi
 
tintam7251 đã viết:
Xin phép bạn quanghai1969, mình chỉnh lại chút cho vừa nhé!
Mã: 
Sub khong_trung()
Dim dic1 As Object, i As Long, j As Long, arr()
Set dic1 = CreateObject("scripting.dictionary")
dk = Range([A1], [A65536].End(3)).Value
Range([B1], [B65536].End(3)).ClearContents
With dic1
   For i = 1 To UBound(dk)
      If dk(i, 1) <> "" Then
         If Not .exists(dk(i, 1)) Then
            .Add dk(i, 1), dk(i, 1)
         Else
            .Remove dk(i, 1)
         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...

Code của bạn là lấy dữ liệu duy nhất mà. Nếu lọc duy nhất thì đâu cần phải nhức đầu viết code dài như thế
 
quanghai1969 đã viết:
Code của bạn là lấy dữ liệu duy nhất mà. Nếu lọc duy nhất thì đâu cần phải nhức đầu viết code dài như thế
Nhấp chuột vào đây để mở rộng...
Code đó cũng hổng phải lấy duy nhất luôn. Giải thuật code ấy là: Chưa có thì cho vào mà có rồi thì xóa bỏ. Vậy nên với những phần tử có số lần trùng là lẻ thì sẽ "bị" lấy hết... Tức code chỉ đúng khi những phần tử có số lần trùng là chẵn mà thôi
Hic...
 
Nguyên văn bởi ndu96081631
Code đó cũng hổng phải lấy duy nhất luôn. Giải thuật code ấy là: Chưa có thì cho vào mà có rồi thì xóa bỏ. Vậy nên với những phần tử có số lần trùng là lẻ thì sẽ "bị" lấy hết... Tức code chỉ đúng khi những phần tử có số lần trùng là chẵn mà thôi
Hic...
Nhấp chuột vào đây để mở rộng...
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
 
ndu96081631 đã viết:
Gần được rồi đấy
Giờ Quang Hải thử với dữ liệu thế này nhé:
A1 = "A"
A2 = "B"
A3 rổng
A4 = "A"
A5 = "B"
A6 = "C"
Xong, chạy code xem thế nào!
Ngoài ra, nếu xóa hết cột A rồi chạy code thì... sao?
Ngoài ra, liệu có thể dùng phép tính nào đó để ReDim vừa đủ cho mảng Arr không? (ở trên ReDim quá thừa rồi...)
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...
Bị mấy cái "Ngoài ra" hơi bị oải.
Hổng xài mảng khỏi Redim được hông ta?
PHP: 
Public Sub GPE()
Dim Rng(), Dic As Object, I As Long, Key As Variant
With Sheet1
        .[C1:C10000].ClearContents
    If .[A65000].End(xlUp).Address = "$A$1" Then
        .[C1].Value = .[A1].Value
    Else
        Set Dic = CreateObject("Scripting.Dictionary")
            Rng = .Range(.[A1], .[A65000].End(xlUp)).Value
        For I = 1 To UBound(Rng, 1)
            If Rng(I, 1) <> "" Then
                If Not Dic.Exists(Rng(I, 1)) Then
                    Dic.Add Rng(I, 1), 1
                Else
                    Dic.Item(Rng(I, 1)) = Dic.Item(Rng(I, 1)) + 1
                End If
            End If
        Next
            For Each Key In Dic.Keys
                If Dic.Item(Key) > 1 Then Dic.Remove Key
            Next
        If Dic.Count Then .[C1].Resize(Dic.Count).Value = _
            Application.WorksheetFunction.Transpose(Dic.Keys)
    End If
End With
    Set Dic = Nothing
End Sub
"Nếu có điều chi sơ sót xin niệm tình ..." Chỉ tiếp.
Hì hì...
 
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.
 
Ba Tê đã viết:
Chưa thấy sai trường hợp nào, quanghai cho xem thử với file ví dụ xem.
Nhấp chuột vào đây để mở rộng...
Anh thiếu công đoạn đánh dấu Zero cho Dic.Item khi có trùng (hoặc đánh dấu gì gì cũng được, miễn là có đánh dấu). Mục đích của việc này là để khi trùng lần 1 ta mới "xử", còn trùng lần 2 trờ đi mà "xử" là trật lất
Ẹc... Ẹc...
Ví dụ dữ liệu thế này nhé:
A1: = "A"
A2, A4, A6 = "B"
A3, A5, A7 = "C"
Test code biết liền ---> Kết quả chính xác sẽ ra 1 kết quả duy nhất là "A"
--------------
Ngoài ra xin nói thêm về cách "biểu diễn" code: Anh liên tục truy xuất Rng(I, 1) như thế là không nên. Trường hợp này nên thông qua 1 biến tmp = Rng(I, 1) sẽ hay hơn ---> Nó là kỹ thuật để tăng tốc đấy!
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Anh thiếu công đoạn đánh dấu Zero cho Dic.Item khi có trùng (hoặc đánh dấu gì gì cũng được, miễn là có đánh dấu). Mục đích của việc này là để khi trùng lần 1 ta mới "xử", còn trùng lần 2 trờ đi mà "xử" là trật lất
Ẹc... Ẹc...
Ví dụ dữ liệu thế này nhé:
A1: = "A"
A2, A4, A6 = "B"
A3, A5, A7 = "C"
Test code biết liền ---> Kết quả chính xác sẽ ra 1 kết quả duy nhất là "A"
--------------
Ngoài ra xin nói thêm về cách "biểu diễn" code: Anh liên tục truy xuất Rng(I, 1) như thế là không nên. Trường hợp này nên thông qua 1 biến tmp = Rng(I, 1) sẽ hay hơn ---> Nó là kỹ thuật để tăng tốc đấy!
Nhấp chuột vào đây để mở rộng...
Cảm ơn Ndu!
Thú thật là chỉ hiểu cách làm theo giải thích của Ndu chứ đọc code của Ndu mình không hiểu hết "ý đồ" trong đó.
Vì thế hiểu sao làm vậy có thể chưa đúng (bị lỗi trong 1 số trường hợp).
Tạm thêm 1 IF nữa xem sao nhé!
PHP: 
Public Sub GPE()
Dim Rng(), Dic As Object, I As Long, Arr(), n As Long, K As Long, L As Long, Tem As Variant
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    .[E1:E10000].ClearContents
    Rng = .[A1:A10000].Value: L = UBound(Rng, 1)
ReDim Arr(1 To L, 1 To 1)
    For I = 1 To L
        Tem = Rng(I, 1)
        If Tem <> "" Then
            If Not Dic.Exists(Tem) Then
                n = n + 1
                Dic.Add Tem, n
                Arr(n, 1) = Tem
            Else
                If Dic.Item(Tem) > 0 Then
                    K = Dic.Item(Tem)
                    Dic.Item(Tem) = 0
                    Arr(K, 1) = Arr(n, 1)
                    n = n - 1
                End If
            End If
        End If
    Next I
        If n Then .[E1].Resize(n).Value = Arr
End With
    Set Dic = Nothing
End Sub
 
Ba Tê đã viết:
Cảm ơn Ndu!
Thú thật là chỉ hiểu cách làm theo giải thích của Ndu chứ đọc code của Ndu mình không hiểu hết "ý đồ" trong đó.
Vì thế hiểu sao làm vậy có thể chưa đúng (bị lỗi trong 1 số trường hợp).
Tạm thêm 1 IF nữa xem sao nhé!
Nhấp chuột vào đây để mở rộng...
Vẫn còn thiếu đấy
Trước khi cho Dic.Item(tem) = 0 thì phải gán thêm Dic.Item(Arr(n,1)) = k nữa mới xong!
Có nghĩa là:
Gán Item của thằng trùng = 0, đồng thời trước đó phải gán Item cuối cùng bằng số k (là số vừa lấy tại Item trùng)
Thử trường hợp dữ liệu thế này sẽ biết:
A1, A4 = "A"
A3, A6 = "C"
A2 = "B"
A5 = "D"
Kết quả đúng sẽ là "D" và "B"
---------------
Lưu ý chổ màu đỏ nha ---> Nếu đảo ngược trật tự này cũng sẽ sai trong trường hợp thằng trùng nằm ở cuối danh sách
Vậy để tối ưu hóa code, ta nên xét trường hợp k = n (tức thằng trùng nằm cuối danh sách)... khi ấy ta chỉ làm 1 thao tác duy nhất là gán Dic.Item(tem) = 0, bỏ qua vụ gán Dic.Item(Arr(n,1)) = k (giảm việc làm cho code)
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Vẫn còn thiếu đấy
Trước khi cho Dic.Item(tem) = 0 thì phải gán thêm Dic.Item(Arr(n,1)) = k nữa mới xong!
Có nghĩa là:
Gán Item của thằng trùng = 0, đồng thời trước đó phải gán Item cuối cùng bằng số k (là số vừa lấy tại Item trùng)
Thử trường hợp dữ liệu thế này sẽ biết:
A1, A4 = "A"
A3, A6 = "C"
A2 = "B"
A5 = "D"
Kết quả đúng sẽ là "D" và "B"
---------------
Lưu ý chổ màu đỏ nha ---> Nếu đảo ngược trật tự này cũng sẽ sai trong trường hợp thằng trùng nằm ở cuối danh sách
Vậy để tối ưu hóa code, ta nên xét trường hợp k = n (tức thằng trùng nằm cuối danh sách)... khi ấy ta chỉ làm 1 thao tác duy nhất là gán Dic.Item(tem) = 0, bỏ qua vụ gán Dic.Item(Arr(n,1)) = k (giảm việc làm cho code)
Nhấp chuột vào đây để mở rộng...
Ái chà, sửa lỗi riết rồi code dài thoòng, nhưng mình tự viết mình mới hiểu.
Hiểu là một chuyện, viết đúng ý muốn hay không lại là chuyện khác.
Híc! Đang 2 For lại "ráng" thành 1 For lại không cho Transpose, "Mệt" thiệt.
Chưa biết nó còn sai trường hợp nào nữa không?
PHP: 
Public Sub GPE()
Dim Rng(), I As Long, Arr(), n As Long, K As Long, L As Long, Tem As Variant
With CreateObject("Scripting.Dictionary")
    [E1:E10000].ClearContents
    Rng = [A1:A10000].Value: L = UBound(Rng, 1)
ReDim Arr(1 To L, 1 To 1)
    For I = 1 To L
        Tem = Rng(I, 1)
        If Tem <> "" Then
            If Not .Exists(Tem) Then
                n = n + 1
                .Add Tem, n
                Arr(n, 1) = Tem
            Else
                If .Item(Tem) > 0 Then
                    If .Item(Tem) = n Then
                        .Item(Tem) = 0
                        n = n - 1
                    Else
                        K = .Item(Tem)
                        .Item(Arr(n, 1)) = K
                        .Item(Tem) = 0
                        Arr(K, 1) = Arr(n, 1)
                        n = n - 1
                    End If
                End If
            End If
        End If
    Next I
        If n Then [E1].Resize(n).Value = Arr
End With
End Sub
 
Lần chỉnh sửa cuối:
Ba Tê đã viết:
Ái chà, sửa lỗi riết rồi code dài thoòng, nhưng mình tự viết mình mới hiểu.
Hiểu là một chuyện, viết đúng ý muốn hay không lại là chuyện khác.
Híc! Đang 2 For lại "ráng" thành 1 For lại không cho Transpose, "Mệt" thiệt.
Chưa biết nó còn sai trường hợp nào nữa không?
PHP: 
Public Sub GPE()
Dim Rng(), I As Long, Arr(), n As Long, K As Long, L As Long, Tem As Variant
With CreateObject("Scripting.Dictionary")
    [E1:E10000].ClearContents
    Rng = [A1:A10000].Value: L = UBound(Rng, 1)
ReDim Arr(1 To L, 1 To 1)
    For I = 1 To L
        Tem = Rng(I, 1)
        If Tem <> "" Then
            If Not .Exists(Tem) Then
                n = n + 1
                .Add Tem, n
                Arr(n, 1) = Tem
            Else
                If .Item(Tem) > 0 Then
                    If .Item(Tem) = n Then
                        .Item(Tem) = 0
                        n = n - 1
                    Else
                        K = .Item(Tem)
                        .Item(Arr(n, 1)) = K
                        .Item(Tem) = 0
                        Arr(K, 1) = Arr(n, 1)
                        n = n - 1
                    End If
                End If
            End If
        End If
    Next I
        If n Then [E1].Resize(n).Value = Arr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Anh để ý chổ này:
Mã: 
If .Item(Tem) = n Then
  [COLOR=#ff0000].Item(Tem) = 0
  n = n - 1[/COLOR]
Else
  K = .Item(Tem)
  .Item(Arr(n, 1)) = K
  [COLOR=#ff0000].Item(Tem) = 0[/COLOR]
  Arr(K, 1) = Arr(n, 1)
  [COLOR=#ff0000]n = n - 1[/COLOR]
End If
Chổ màu đỏ ấy! Dù điêu kiện IF đúng hay sai thì chúng.. vẫn thế!
Vậy có phải nên cho mấy dòng màu đỏ ấy ra ngoài IF hợp lý hơn không:
Mã: 
ElseIf .Item(Tem) > 0 Then
  K = .Item(Tem)
  .Item(Tem) = 0
  If K < n Then
    .Item(Arr(n, 1)) = K
    Arr(K, 1) = Arr(n, 1)
  End If
  n = n - 1
End If
So sánh sẽ thấy bây giờ là.. y chang code của em rồi
Ẹc... Ẹc...
------------------
Ngoài ra sau khi chạy vòng lập xong, ta nên phân ra 3 trường hợp xảy ra:
1> Dic.Count = 0 ===> Vùng đang xét là rổng (không có dữ liệu nào)
2> Dic.Count > 0: có 2 trường hợp nhỏ:
a> n > 0: Tìm thấy
b> n = 0: Tất cả dữ liệu đều bị trùng​
-----------------
Bài này anh For Each... sẽ hay hơn vì với vùng nhiều dòng nhiều cột, chẳng lẽ anh phải thêm 1 vòng lập nữa sao?


​
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Anh để ý chổ này:
Mã: 
If .Item(Tem) = n Then
  [COLOR=#ff0000].Item(Tem) = 0
  n = n - 1[/COLOR]
Else
  K = .Item(Tem)
  .Item(Arr(n, 1)) = K
  [COLOR=#ff0000].Item(Tem) = 0[/COLOR]
  Arr(K, 1) = Arr(n, 1)
  [COLOR=#ff0000]n = n - 1[/COLOR]
End If
Chổ màu đỏ ấy! Dù điêu kiện IF đúng hay sai thì chúng.. vẫn thế!
Vậy có phải nên cho mấy dòng màu đỏ ấy ra ngoài IF hợp lý hơn không:
Mã: 
ElseIf .Item(Tem) > 0 Then
  K = .Item(Tem)
  .Item(Tem) = 0
  If K < n Then
    .Item(Arr(n, 1)) = K
    Arr(K, 1) = Arr(n, 1)
  End If
  n = n - 1
End If
So sánh sẽ thấy bây giờ là.. y chang code của em rồi
Ẹc... Ẹc...
------------------
Ngoài ra sau khi chạy vòng lập xong, ta nên phân ra 3 trường hợp xảy ra:
1> Dic.Count = 0 ===> Vùng đang xét là rổng (không có dữ liệu nào)
2> Dic.Count > 0: có 2 trường hợp nhỏ:
a> n > 0: Tìm thấy
b> n = 0: Tất cả dữ liệu đều bị trùng​
-----------------
Bài này anh For Each... sẽ hay hơn vì với vùng nhiều dòng nhiều cột, chẳng lẽ anh phải thêm 1 vòng lập nữa sao?


​
Nhấp chuột vào đây để mở rộng...
Đúng vậy.
Nhưng đã nói là tự viết, tự sửa mình mới hiểu hết tác dụng của nó, đọc code của người khác thì... hổng hiểu.
Lu xu bu nhưng rất đáng học hỏi.
Cảm ơn Ndu nhé!
 
Ba Tê đã viết:
Đúng vậy.
Nhưng đã nói là tự viết, tự sửa mình mới hiểu hết tác dụng của nó, đọc code của người khác thì... hổng hiểu.
Lu xu bu nhưng rất đáng học hỏi.
Cảm ơn Ndu nhé!
Nhấp chuột vào đây để mở rộng...
Anh học code VBA rất nhanh, đây là điều em khâm phục anh nhất (ngày xưa em học chậm như rùa vì tự thấy bản thân kém thông mình)
Nhưng nói thật (anh đừng buồn). Có lẽ anh nên trao chuốt thêm về cách "biểu diễn" ý tưởng:
- Tên biến nên đặt sao cho ai cũng hiểu "nó" là đang đại diện cho cái gì (em ưu tiên tiếng Anh)
- Phần bố cục nên chặt chẽ. Một khi đã hoàn tất code, chạy ra kết quả đúng rồi ta cũng nên tiến hành phần tối ưu hóa (bằng cách thí nghiệm với dữ liệu lớn sẽ biết)
- Bẫy lỗi phải luôn luôn có (dù rằng anh biết sẽ không có lỗi nào). Nên thí nghiệm với các trường hợp đặt biệt nhất của dữ liệu để phát hiện
----------------------
Đây chỉ là kinh nghiệm cá nhân trong quá trình nghiên cứu lập trình. Có gì không phải mong anh bỏ qua (để chúng ta còn học hỏi lẫn nhau)
Ẹc... Ẹc...
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

S
Em muốn copy các dữ liệu ô họ tên đã bị gộp từ B9 đến E9. Em muốn pass sang ô B9 (sheet mới). Thank (1 người xem)
Trả lời
4
Đọc
48
samthai8017
S
S
Xin các Pro chia sẻ giúp
Trả lời
4
Đọc
48
samthai8017
S
GPE-Trợ Lý
TALKSHOW 16 BẬT MÍ THỦ THUẬT GOOGLE SHEET: TỔNG HỢP DỮ LIỆU TỪ NHIỀU SHEET & FILE BĂNG IMPORTRANGE (1 người xem)
Trả lời
1
Đọc
475
GPE-Trợ Lý
GPE-Trợ Lý
T
  • Question Question
Kết quả lọc dữ liệu từ sheet TONG HOP qua từng chi tiết (1 người xem)
Trả lời
0
Đọc
17
truc l
T
B
Em nhờ các bro giúp giải pháp in nhiều file ạ (1 người xem)
Trả lời
3
Đọc
57
Hoàng Tuấn 868
H
T
  • Question Question
Code VBA tra cứu kết quả trả về mảng dữ liệu
    • Cười
Trả lời
17
Đọc
321
LOGANWover
L
HeSanbi
  • Question Question
VBScript.RegExp sẽ bị xóa khỏi Windows: thư viện Pcre2 giải pháp thay thế tối ưu
    • Thích
    • Cảm ơn
Trả lời
1
Đọc
70
HeSanbi
HeSanbi
S
Xin hỏi các pro. Em muốn copy các dữ liệu ô họ tên đã bị gộp từ B9 đến E9. Em muốn pass sang ô B9 (sheet mới). (1 người xem)
Trả lời
3
Đọc
60
samthai8017
S
T
Nhờ anh chị tìm giúp nguyên nhân không nhảy dữ liệu Pivotable (1 người xem)
Trả lời
2
Đọc
65
thuhacoicoi
T
HeSanbi
  • Question Question
Chuyển mã VBA ứng dụng Excel 32 bit hoạt động trên cả 64bit (Hoàn toàn 0 phí)
    • Thích
Trả lời
0
Đọc
57
HeSanbi
HeSanbi
T
Ctrl + Shift + 0 không dùng để unhide cột được
Trả lời
24
Đọc
22K
Oji
O
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail. (1 người xem)
    • Thích
    • Yêu thích
Trả lời
19
Đọc
4K
Hoàng Tuấn 868
H
Gà Công Nghệ
Nhờ anh chị chuyển hộ font chữ excel
Trả lời
3
Đọc
95
HeSanbi
HeSanbi
huytamlinh
Anh Chị giúp em sửa lỗi định dạng với ạ !
Trả lời
3
Đọc
47
Hoàng Tuấn 868
H
T
  • Question Question
Xin giúp em mã lệnh tổng hợp tự động lên bảng tổng hợp! (1 người xem)
Trả lời
1
Đọc
58
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
4
Đọc
922
nguyendang95
N
V
Quản lý xuất nhập vật tư trong kho
Trả lời
19
Đọc
765
LOGANWover
L
phuongnam366377
Học C++ từ số 0 – Bài học đầu tiên
    • Cảm ơn
Trả lời
4
Đọc
356
phuongnam366377
phuongnam366377
F
Mấy cao thủ giúp dùm mình với. File excel bị lỗi mà mình không biết lỗi chỗ nào để sửa. (1 người xem)
Trả lời
2
Đọc
113
firstbood
F
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
3 4 5
Trả lời
438
Đọc
59K
sát thủ uyên ương
S
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom