Xin giúp đỡ về Scripting.Dictionary (2 người xem)

[vanlemon]

Gởi anh chị.

Em đang muốn học hỏi về Scripting.Dictionary ạ

Em có một bảng giá trị từ A2:A8

Bây giờ em Giả sử trên cột B1:Bn mà có giá trị giống với vùng A2:A8 thì xoá luôn dòng đó.

Xin anh chị giúp em đoạn code VBA nhé.

Em xin cám ơn nhiều nhiều ạ

 

[HungQuoc49]

Gởi anh chị.

Em đang muốn học hỏi về Scripting.Dictionary ạ

Em có một bảng giá trị từ A2:A8

Bây giờ em Giả sử trên cột B1:Bn mà có giá trị giống với vùng A2:A8 thì xoá luôn dòng đó.

Xin anh chị giúp em đoạn code VBA nhé.

Em xin cám ơn nhiều nhiều ạ

Dùng thử đoạn code này xem sao

Public Sub Xoa()
Dim DL, Dic As Object, r As Long

Set DL = Sheet1.Range("B1", Sheet1.Range("H1000000").End(xlUp))
Set Dic = CreateObject("scripting.dictionary")

For r = 2 To 8
If Not Dic.exists(Sheet1.Range("A" & r).Value) Then
Dic.Add Sheet1.Range("A" & r).Value, ""
End If
Next r

For r = DL.Rows.Count To 1 Step -1
If Dic.exists(DL(r, 1).Value) Then
DL.Rows(r).Delete
End If
Next r

Set Dic = Nothing
End Sub

 

[hung2412]

Phong trào Dictionary. Code cùi:
[GPECODE=vb]Sub Delete()
Dim Dic As Object
Dim i As Long
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To 8
If Not Dic.exists(Cells(i, 1).Value) Then
Dic.Add Cells(i, 1).Value, Empty
End If
Next
For i = [B65536].End(xlUp).Row To 10 Step -1
If Dic.exists(Cells(i, 2).Value) Then
Cells(i, 2).EntireRow.Delete
End If
Next
End Sub[/GPECODE]

 

[HungQuoc49]

Khuyến mại một cách không cần dic

Public Sub Xoa_Dong()
Dim Mau, DL, r As Long

Mau = Join(Application.Transpose(Sheet1.Range("A2:A8")), "#")
Set DL = Sheet1.Range("B1", Sheet1.Range("H1000000").End(xlUp))

For r = DL.Rows.Count To 1 Step -1
If InStr(1, Mau, DL(r, 1), 1) Then
DL.Rows(r).Delete
End If
Next r

End Sub

 

[vanlemon]

Dùng thử đoạn code này xem sao

Public Sub Xoa()
Dim DL, Dic As Object, r As Long

Set DL = Sheet1.Range("B1", Sheet1.Range("H1000000").End(xlUp))
Set Dic = CreateObject("scripting.dictionary")

For r = 2 To 8
If Not Dic.exists(Sheet1.Range("A" & r).Value) Then
Dic.Add Sheet1.Range("A" & r).Value, ""
End If
Next r

For r = DL.Rows.Count To 1 Step -1
If Dic.exists(DL(r, 1).Value) Then
DL.Rows(r).Delete
End If
Next r

Set Dic = Nothing
End Sub

Quá tuyệt luôn bạn ơi
Cám ơn bạn nhiều nhé!

 

[vanlemon]

Phong trào Dictionary. Code cùi:
[GPECODE=vb]Sub Delete()
Dim Dic As Object
Dim i As Long
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To 8
If Not Dic.exists(Cells(i, 1).Value) Then
Dic.Add Cells(i, 1).Value, Empty
End If
Next
For i = [B65536].End(xlUp).Row To 10 Step -1
If Dic.exists(Cells(i, 2).Value) Then
Cells(i, 2).EntireRow.Delete
End If
Next
End Sub[/GPECODE]

Không hiểu sao code này bỏ vào nó không chạy bạn ơi

 

[hung2412]

Không hiểu sao code này bỏ vào nó không chạy bạn ơi

Vẫn chạy bình thường nhé (Tôi vừa Text lại), bạn thử lại xem.

 

[haonlh]

Vẫn chạy bình thường nhé (Tôi vừa Text lại), bạn thử lại xem.

Tôi cũng không chạy được.

Khi chép code vô, thấy các lệnh If đều đổi màu đỏ
For i = 1 To 8 'Sao Kg duoc??
If Not Dic.exists(Cells(i, 1).Value) Then
Dic.Add Cells(i, 1).Value, Empty
End If
Next
For i = [B65536].End(xlUp).Row To 10 Step -1
If Dic.exists(Cells(i, 2).Value) Then
Cells(i, 2).EntireRow.Delete
End If
Hình như chỉnh sửa gì trong Tools\References (của cửa sổ viết code)

 

[giangleloi]

Tôi cũng không chạy được.

Khi chép code vô, thấy các lệnh If đều đổi màu đỏ
For i = 1 To 8 'Sao Kg duoc??
If Not Dic.exists(Cells(i, 1).Value) Then
Dic.Add Cells(i, 1).Value, Empty
End If
Next
For i = [B65536].End(xlUp).Row To 10 Step -1
If Dic.exists(Cells(i, 2).Value) Then
Cells(i, 2).EntireRow.Delete
End If
Hình như chỉnh sửa gì trong Tools\References (của cửa sổ viết code)

Chỉnh ở đây nè bạn:
http://www.giaiphapexcel.com/forum/showthread.php?60643-Tổng-quan-về-Scripting-Dictionary

 

[haonlh]

Chỉnh ở đây nè bạn:
http://www.giaiphapexcel.com/forum/showthread.php?60643-Tổng-quan-về-Scripting-Dictionary

Đã chỉnh trên E2003 mà vẫn không được. Tôi đang chạy E2003, có cài E2010 nhưng vì chưa quen nên vẫn để đó, không mấy khi chạy nó.

 

[NguyenThienHa]

Gửi các anh chị trên diễn đàn
Mình đang tự học Scripting.Dictionary nhưng loay hoay mãi vẫn chưa làm được file này, mình có tham khảo sách tác giả Nguyễn khắc Duy nhưng kết quả vẫn chưa ra sao mong các anh chị trên diễn đàn giúp đỡ
Cám ơn các anh chị

 

[gtri]

Gửi các anh chị trên diễn đàn
Mình đang tự học Scripting.Dictionary nhưng loay hoay mãi vẫn chưa làm được file này, mình có tham khảo sách tác giả Nguyễn khắc Duy nhưng kết quả vẫn chưa ra sao mong các anh chị trên diễn đàn giúp đỡ
Cám ơn các anh chị

Sửa lại vài chỗ, bạn kiểm tra và so sánh thử xem sao

Sub Tonghop()
Dim EndR As Long, i As Long, j     'Thêm biến đếm j
Dim arr1, arr2, Dic
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
EndR = .Range("E65536").End(xlUp).Row
arr1 = .Range("D2:J" & EndR).Value
ReDim arr2(1 To EndR, 1 To 3)     'Khai báo lại số cột arr2- từ 2 to 3 thành 1 to 3
For i = LBound(arr1, 1) To UBound(arr1, 1)
    If arr1(i, 2) <> "" And Not Dic.Exists(arr1(i, 2)) Then
    j = j + 1
    Dic.Add arr1(i, 2), j     'Nạp biến đếm j vào item để sau lấy làm chỉ số dòng
'Thay Dic.count bằng j
    arr2(j, 1) = arr1(i, 2)
    arr2(j, 2) = Right(arr1(i, 4), 5) & "(" & arr1(i, 1) & ")" & arr1(i, 7)     'Sửa arr2(...,4) thành arr2(...,2)
    arr2(j, 3) = arr2(j, 3) + arr1(i, 7)      'Sửa arr2(...,7) thành arr2(...,3)
    Else
'Nếu đã có trong Dic, lấy chỉ số dòng của arr2=item(arr1(i,2))
    arr2(Dic.Item(arr1(i, 2)), 2) = arr2(Dic.Item(arr1(i, 2)), 2) & ", " & Right(arr1(i, 4), 5) & "(" & arr1(i, 1) & ")" & arr1(i, 7)
    arr2(Dic.Item(arr1(i, 2)), 3) = arr2(Dic.Item(arr1(i, 2)), 3) + arr1(i, 7)
    End If
Next i
    .Range("P2").Resize(Dic.Count, 3).Value = arr2
    End With
End Sub

 

[NguyenThienHa]

Cám ơn bạn gtri và các bạn trên diễn đàn
Cho mình hỏi thêm một câu nữa
cột Số Hiệu sau khi chạy code có những số hiệu trùng nhau ta có thể sửa code gôm lại được không cụ thể như sau:

[TABLE="width: 872"]
[TR]
[TD]
MÃ[/TD]
[TD]SỐ HIỆU[/TD]
[TD]SỐ LƯỢNG[/TD]
[/TR]
[TR]
[TD]00011[/TD]
[TD]10-02(131)3, 11-03(49)5, 02-02(10)10, 03-08(10)1000, 03-08(63)12, 05-01(44)1, 04-02(89)1, 04-03(151)1, 04-03(215)4, 02-10(18)5, 07-05(57)2[/TD]
[TD="align: right"]1044[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]
sữa code gôm lại như sau[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]
MÃ[/TD]
[TD]SỐ HIỆU[/TD]
[TD]SỐ LƯỢNG[/TD]
[/TR]
[TR]
[TD]00011[/TD]
[TD]10-02(131)3, 11-03(49)5, 02-02(10)10, 03-08(10)1000(63)12, 05-01(44)1, 04-02(89)1, 04-03(151)1(215)4, 02-10(18)5, 07-05(57)2[/TD]
[TD="align: right"]1044[/TD]
[/TR]
[/TABLE]

 

[gtri]

Cám ơn bạn gtri và các bạn trên diễn đàn
Cho mình hỏi thêm một câu nữa
cột Số Hiệu sau khi chạy code có những số hiệu trùng nhau ta có thể sửa code gôm lại được không cụ thể như sau:

[TABLE="width: 872"]
[TR]
[TD]
MÃ[/TD]
[TD]SỐ HIỆU[/TD]
[TD]SỐ LƯỢNG[/TD]
[/TR]
[TR]
[TD]00011[/TD]
[TD]10-02(131)3, 11-03(49)5, 02-02(10)10, 03-08(10)1000, 03-08(63)12, 05-01(44)1, 04-02(89)1, 04-03(151)1, 04-03(215)4, 02-10(18)5, 07-05(57)2[/TD]
[TD="align: right"]1044[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]
sữa code gôm lại như sau[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]
MÃ[/TD]
[TD]SỐ HIỆU[/TD]
[TD]SỐ LƯỢNG[/TD]
[/TR]
[TR]
[TD]00011[/TD]
[TD]10-02(131)3, 11-03(49)5, 02-02(10)10, 03-08(10)1000(63)12, 05-01(44)1, 04-02(89)1, 04-03(151)1(215)4, 02-10(18)5, 07-05(57)2[/TD]
[TD="align: right"]1044[/TD]
[/TR]
[/TABLE]

Bổ sung thêm đoạn code ( Phần tô đậm )
Bạn kiểm tra xem sao

Sub Tonghop()
Dim EndR As Long, i As Long, j
[B]Dim Tam, k[/B]
Dim arr1, arr2, Dic

Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
EndR = .Range("E65536").End(xlUp).Row
arr1 = .Range("D2:J" & EndR).Value
ReDim arr2(1 To EndR, 1 To 3)
For i = LBound(arr1, 1) To UBound(arr1, 1)
    If arr1(i, 2) <> "" And Not Dic.Exists(arr1(i, 2)) Then
    j = j + 1
    Dic.Add arr1(i, 2), j
    arr2(j, 1) = arr1(i, 2)
    arr2(j, 2) = Right(arr1(i, 4), 5) & "(" & arr1(i, 1) & ")" & arr1(i, 7)
    arr2(j, 3) = arr2(j, 3) + arr1(i, 7)
    Else
    
[B]    If InStr(arr2(Dic.Item(arr1(i, 2)), 2), Right(arr1(i, 4), 5)) Then
    Tam = Split(arr2(Dic.Item(arr1(i, 2)), 2), ",")
    For k = 0 To UBound(Tam)
    If InStr(Tam(k), Right(arr1(i, 4), 5)) Then
    Tam(k) = Tam(k) & "(" & arr1(i, 1) & ")" & arr1(i, 7)
    Tam = Join(Tam, ", ")
    arr2(Dic.Item(arr1(i, 2)), 2) = Application.Trim(Tam)
    arr2(Dic.Item(arr1(i, 2)), 3) = arr2(Dic.Item(arr1(i, 2)), 3) + arr1(i, 7)
    Exit For
    End If
    Next k
    Else
[/B]    
    arr2(Dic.Item(arr1(i, 2)), 2) = arr2(Dic.Item(arr1(i, 2)), 2) & ", " & Right(arr1(i, 4), 5) & "(" & arr1(i, 1) & ")" & arr1(i, 7)
    arr2(Dic.Item(arr1(i, 2)), 3) = arr2(Dic.Item(arr1(i, 2)), 3) + arr1(i, 7)
[B]    End If[/B]
    End If
Next i
    .Range("P2").Resize(Dic.Count, 3).Value = arr2
    End With
End Sub

---
Thêm biến phụ có lẽ sẽ dễ nhìn hơn