Cần giúp cách làm khác để bỏ cột phụ của cách làm hiện tại trong bài tập vba (1 người xem)

[Cô Bé Dễ Thương]

Cháu chào cô bác và các anh chị.
Được chú Mỹ (ptm0412) cho code và cháu sửa lại theo ý của mình.
Do lúc trước xin code chỉ có 1 trường hợp nên nảy sinh thêm nhiều cột phụ.
- Cách giải của em (có trong file đính kèm):Bằng cách thêm cột phụ và mỗi cột phụ tương đương một Sub, cuối cùng tạo ra một Sub nữa dùng để gộp các cột phụ lại để gán vào cột Dạng ở bảng 1 (nút Run và Xóa đã thể hiện cách giải)<--- nhưng thô quá, số lượng Dạng lớn đến hàng trăm thì...tay to mất!
- Mong muốn: Vẫn dùng Dict vba(hoặc cách khác) mà không dùng đến các cột phụ.
Do trình độ không thể khắc phục được, cháu đăng lên nhờ các bác và các bạn giúp đỡ cho ạ!
(cụ thể file đính kèm)

 

[ptm0412]

Làm được (chế cháo) vậy là cũng có tiến bộ.
Code sau dùng Dict với item là mảng 2 thành phần:
- thành phần 1 là ký hiệu A, B, C, D, lấy từ mảng Sample,
- thành phần 2 là thứ tự i của sKey, dùng làm thứ tự cột cho mảng kết quả (lưu ý là cộng 1)

Sub CheckNote_All()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("N5:Q8")
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, Array(Sample(i, 4), i)
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 1 To 5)
For i = 1 To DataRows
    sKey = SData(i, 1).Interior.Color & _
    "|" & SData(i, 2).Interior.Color & _
    "|" & SData(i, 3).Interior.Color
    If Dict.exists(sKey) Then
        RArr(i, 1) = Dict.Item(sKey)(0)
        RArr(i, Dict.Item(sKey)(1) + 1) = Dict.Item(sKey)(0)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), 5).Value = RArr
End Sub

 

[Cô Bé Dễ Thương]

Cháu sửa lại và đã đúng với yêu cầu, Sub: CheckNote_All_Fix(ở cuối bài). Và hiện kết quả chỉ mỗi ở cột F trên bảng tính.
- Cháu cũng đã nghĩ tới đặt Item = Array. Nhưng mầm không ra được cú pháp. Với lai đọc ở Thớt khác thấy có dòng ghi là "Item không nhận giá trị mảng".Lên cháu mới xin trợ giúp.
- Cho cháu hỏi thêm chỗ này:
Dict.Add sKey, Array(Sample(i, 4), i) - cái này là Add cái Array(Sample(i, 4), i) làm Item.
Giả sử cháu lấy 2 giá trị Sample(i, 4) và Sample(i, 5) vào Array thì cú pháp như nào ạ (nghĩa là Item là mảng có 2 giá trị với mỗi 1 đơn vị của i ạ)
Cảm ơn chú rất nhiều!

Làm được (chế cháo) vậy là cũng có tiến bộ.
Code sau dùng Dict với item là mảng 2 thành phần:
- thành phần 1 là ký hiệu A, B, C, D, lấy từ mảng Sample,
- thành phần 2 là thứ tự i của sKey, dùng làm thứ tự cột cho mảng kết quả (lưu ý là cộng 1)

Sub CheckNote_All()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("N5:Q8")
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, Array(Sample(i, 4), i)
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 1 To 5)
For i = 1 To DataRows
    sKey = SData(i, 1).Interior.Color & _
    "|" & SData(i, 2).Interior.Color & _
    "|" & SData(i, 3).Interior.Color
    If Dict.exists(sKey) Then
        RArr(i, 1) = Dict.Item(sKey)(0)
        RArr(i, Dict.Item(sKey)(1) + 1) = Dict.Item(sKey)(0)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), 5).Value = RArr
End Sub

Sub CheckNote_All_Fix()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("N5:Q8")
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, Array(Sample(i, 4), i)
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 1 To 1)
For i = 1 To DataRows
    sKey = SData(i, 1).Interior.Color & _
    "|" & SData(i, 2).Interior.Color & _
    "|" & SData(i, 3).Interior.Color
    If Dict.exists(sKey) Then
        RArr(i, 1) = Dict.Item(sKey)(0)
        'cháu bo dong lenh nay
        'RArr(i, Dict.Item(sKey)(1) + 1) = Dict.Item(sKey)(0)
    End If
Next
'Cháu đổi .Resize(UBound(RArr, 5) thành .Resize(UBound(RArr, 1)
Range("F5").Resize(UBound(RArr, 1), 1).Value = RArr
End Sub

 

[ptm0412]

Với lai đọc ở Thớt khác thấy có dòng ghi là "Item không nhận giá trị mảng".
:

Giả sử cháu lấy 2 giá trị Sample(i, 4) và Sample(i, 5) vào Array thì cú pháp như nào ạ (nghĩa là Item là mảng có 2 giá trị ạ)

Thớt nào? nhảm nhí
Cú pháp Arr = Array(phần tử 1, phần tử 2, ... phần tử n), phần tử có kiểu tuỳ ý
Lưu ý tạo mảng bằng Array() luôn luôn là mảng 1 chiều và phần tử thứ nhất là thành phần có thứ tự là 0 (không phải 1)
Truy xuất phần tử thứ n là Arr(n-1)

 

[Cô Bé Dễ Thương]

Thớt nào? nhảm nhí
Cú pháp Arr = Array(phần tử 1, phần tử 2, ... phần tử n), phần tử có kiểu tuỳ ý
Lưu ý tạo mảng bằng Array() luôn luôn là mảng 1 chiều và phần tử thứ nhất là thành phần có thứ tự là 0 (không phải 1)
Truy xuất phần tử thứ n là Arr(n-1)

Vâng. Cháu đọc trượt cột dọc hihi. Họ viết Item thì giá trị tùy ý. Còn ông Key thì không nhận giá trị mảng(arry)
Chỗ này giúp cháu với, theo như bài trên:

 

[ptm0412]

Chỗ này giúp cháu với, theo như bài trên:

mở rộng Sample ra 5 cột, rồi cứ theo cú pháp mà làm. Tuy nhiên làm kiểu 1-A, 2-B thì không có thứ tự cột mà xài
__
Chưa thả tim kìa

 

[Cô Bé Dễ Thương]

mở rộng Sample ra 5 cột, rồi cứ theo cú pháp mà làm. Tuy nhiên làm kiểu 1-A, 2-B thì không có thứ tự cột mà xài
__
Chưa thả tim kìa

Thứ tự thì mần chỗ khác ra được ạ. Còn tắc 1 tý:
Chỗ này này ạ! Dict.Add sKey, Array(Sample(i, 4), i)
- i trong này là gì chú nhỉ?
- Cháu chưa biết làm sao để thêm Sample(i, 5) vào Array(Sample(i, 4), i) này ạ. Để Item là 2 giá trị Sample(i, 4),Sample(i, 5).

 

[SA_DQ]

1 cách cù lần này để bạn tham khảo:

Sub NhanDangTheoChuan()
 Dim Cls As Range
 Dim J As Long, Col As Integer, Rws As Long, Tong As Long
 
 Rws = [B5].End(xlDown).Row
 For J = 5 To Rws
    For Each Cls In Range(Cells(J, "C"), Cells(J, "E"))
        Tong = Tong + Cls.Interior.ColorIndex
    Next Cls
    Cells(J, "F").Value = Switch(Tong = 98, "A", Tong = 114, "B", Tong = 105, "C", Tong = 99, "D")
    Tong = 0
 Next J
End Sub

 

[ptm0412]

Chỗ này này ạ! Cháu chưa biết làm sao để thêm Sample(i, 5) vào Array(Sample(i, 4), i) này ạ.

Nếu muốn item là array 3 phần tử thì cứ nhét phần tử thứ 3 vào sau phần tử thứ 2. Đầu óc đi đâu rồi?

1 cách cù lần này để bạn tham khảo:

ColorIndex chỉ có 56 ẻm, nếu người dùng sử dụng Interior.Color thì tới 16 triệu, những ẻm Color RGB gần nhau bị gán chung 1 ColorIndex, và sẽ sai. Ngoài ra tính tổng cũng có khả năng sai nếu như 3 màu lần lượt là 13, 14, 15 và 6, 8, 28. Tổng bằng 42

 

[Cô Bé Dễ Thương]

Nếu muốn item là array 3 phần tử thì cứ nhét phần tử thứ 3 vào sau phần tử thứ 2. Đầu óc đi đâu rồi?


ColorIndex chỉ có 56 ẻm, nếu người dùng sử dụng Interior.Color thì tới 16 triệu, những ẻm Color RGB gần nhau bị gán chung 1 ColorIndex, và sẽ sai. Ngoài ra tính tổng cũng có khả năng sai nếu như 3 màu lần lượt là 13, 14, 15 và 6, 8, 28. Tổng bằng 42

- Array(Sample(i, 4), i) - cái i là 1 phần tử của Array lấy số thứ tự phải không ạ?
-Cháu cảm ơn! chắc dùng key chuỗi mới max trường hợp bác @SA_DQ ạ. Vì bài này thuộc 1 thớt cháu bị mắng quá. Nên cho sang đây ạ!

 

[SA_DQ]

chuỗi mới max trường hợp bác @@SA_DQ ạ. Vì bài này thuộc 1 thớt . . . bị mắng quá.

Thì đã bảo là cách cù lần mà lị!

 

[ptm0412]

- Array(Sample(i, 4), i) - cái i là 1 phần tử của Array lấy số thứ tự phải không ạ?
-Cháu cảm ơn! chắc dùng kye chuỗi mới max trường hợp bác @SA_DQ ạ. Vì bài này thuộc 1 thớt cháu bị mắng quá. Nên cho sang đây ạ!

Thêm 1 phần tử: Array(Sample(i, 4), Sample(i,5), i)
Rõ ràng là i dùng để làm thứ tự cột, không chịu đọc kỹ
Chủ đề này sẽ tiếp tục bị mắng thôi, cứ chuẩn bị ...

 

[Cô Bé Dễ Thương]

Thì đã bảo là cách cù lần mà lị!

Ôi cháu không dám. Học code cháu thấy khó và chết dở chỗ cú pháp và lý luận, giống như học ngoại ngữ bắt buộc phải tự học từ vựng. Mà đc cho code chạy đc đều có cái phần lý luận và cú pháp dùng được nhiều lần. Cháu đâm lao theo lao nên có gì mới phát sinh cũng dính tý key chuỗi khi dùng Dict ạ!

Bài đã được tự động gộp: 5/3/21

Thêm 1 phần tử: Array(Sample(i, 4), Sample(i,5), i)
Rõ ràng là i dùng để làm thứ tự cột, không chịu đọc kỹ
Chủ đề này sẽ tiếp tục bị mắng thôi, cứ chuẩn bị ...

Thấy nick chú xanh xanh và được mắng là may mắn lắm rồi!
Hi vọng đến tối có code mở rộng ra 5 cột với Array(Sample(i, 4), Sample(i,5), i) là Item

 

[huuthang_bd]

Cũng không nên nhét quá nhiều thứ vào Dictionary. Dictionary chỉ cần ghi lại chỉ số dòng, sau đó thì cứ từ chỉ số dòng mà lấy dữ liệu từ mảng ra thôi. Nhất là khi muốn lấy thông tin từ nhiều cột.

'...
Set Sample = Range("N5:Q8")
SampleArr = Range("Q5:Q8").Value
For i = 1 To Sample.Rows.Count
    '...
    Dict.Add sKey, i
    '...
Next
'...
ReDim RArr(1 To DataRows, 0 To UBound(SampleArr, 1))
For i = 1 To DataRows
    '...
    If Dict.Exists(sKey) Then
        k = Dict.Item(sKey)
        RArr(i, 0) = SampleArr(k,1)
        RArr(i, k) = SampleArr(k,1)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 1) + 1).Value = RArr

 

[Cô Bé Dễ Thương]

Cũng không nên nhét quá nhiều thứ vào Dictionary. Dictionary chỉ cần ghi lại chỉ số dòng, sau đó thì cứ từ chỉ số dòng mà lấy dữ liệu từ mảng ra thôi. Nhất là khi muốn lấy thông tin từ nhiều cột.

'...
Set Sample = Range("N5:Q8")
SampleArr = Range("Q5:Q8").Value
For i = 1 To Sample.Rows.Count
    '...
    Dict.Add sKey, i
    '...
Next
'...
ReDim RArr(1 To DataRows, 0 To UBound(SampleArr, 1))
For i = 1 To DataRows
    '...
    If Dict.Exists(sKey) Then
        k = Dict.Item(sKey)
        RArr(i, 0) = SampleArr(k,1)
        RArr(i, k) = SampleArr(k,1)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 1) + 1).Value = RArr

Sub CheckNote_All_BAC_huuthang_bd()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("N5:Q8")
SampleArr = Range("Q5:Q8").Value
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, i
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 0 To UBound(SampleArr, 1))
For i = 1 To DataRows
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    If Dict.Exists(sKey) Then
        k = Dict.Item(sKey)
        RArr(i, 0) = SampleArr(k, 1)
        RArr(i, k) = SampleArr(k, 1)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 1) + 1).Value = RArr
End Sub

Như tóm tắt code trên i được gán là Item.
Cháu sửa lại rồi. Mà chưa chạy được. Không biết thiếu chỗ nào ạ?

 

[huuthang_bd]

Sai chỗ màu đỏ.

Sub CheckNote_All_BAC_huuthang_bd()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("N5:Q8")
SampleArr = Range("Q5:Q8").Value
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, i
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 0 To UBound(SampleArr, 1))
For i = 1 To DataRows
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    If Dict.Exists(sKey) Then
        k = Dict.Item(sKey)
        RArr(i, 0) = SampleArr(k, 1)
        RArr(i, k) = SampleArr(k, 1)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 1) + 1).Value = RArr
End Sub

 

[Cô Bé Dễ Thương]

Thêm 1 phần tử: Array(Sample(i, 4), Sample(i,5), i)
Rõ ràng là i dùng để làm thứ tự cột, không chịu đọc kỹ
Chủ đề này sẽ tiếp tục bị mắng thôi, cứ chuẩn bị ...

Có rồi chú Mỹ ơi. Cháu mở rộng được mảng của Item rồi(file Excel đính kèm, có thay đổi dữ liệu). (Nếu muốn có thêm cột thứ tự thì cháu tạo ra 1 mảng RArr3 rồi gán vào vị trí cần gán vị trí cần)
Cháu cảm ơn các bác đã giúp cháu bài này trong chiều hôm nay.

Sub CheckNote_All_FIx_co_2_ten()
Dim Dict, SData As Range, RArr1(), Sample As Range, RArr2()
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("o5:s8")
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, Array(Sample(i, 4), Sample(i, 5))
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr1(1 To DataRows, 1 To 1)
ReDim RArr2(1 To DataRows, 1 To 1)
For i = 1 To DataRows
    sKey = SData(i, 1).Interior.Color & _
    "|" & SData(i, 2).Interior.Color & _
    "|" & SData(i, 3).Interior.Color
    If Dict.exists(sKey) Then
        RArr1(i, 1) = Dict.Item(sKey)(0)
        RArr2(i, 1) = Dict.Item(sKey)(1)
    End If
Next
Range("F5").Resize(UBound(RArr1, 1), 1).Value = RArr1
Range("g5").Resize(UBound(RArr2, 1), 1).Value = RArr2
End Sub

Bài đã được tự động gộp: 5/3/21

Sai chỗ màu đỏ.

Sub CheckNote_All_BAC_huuthang_bd()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("N5:Q8")
SampleArr = Range("Q5:Q8").Value
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, i
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 0 To UBound(SampleArr, 1))
For i = 1 To DataRows
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    If Dict.Exists(sKey) Then
        k = Dict.Item(sKey)
        RArr(i, 0) = SampleArr(k, 1)
        RArr(i, k) = SampleArr(k, 1)
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 1) + 1).Value = RArr
End Sub

Cháu cảm ơn bác đã cho cháu code ạ!Nhìn thấy phần tóm tắt của bác mơi nghĩ đến tạo ra nhiều mảng chứa cột tên khác nhau!
Do có yêu cầu mới! Và đã tự mần theo cách mở rộng thêm phần tử trong Array là Item. đã chạy được rồi ạ!

 

[ptm0412]

Có rồi chú Mỹ ơi. Cháu mở rộng được mảng của Item rồi(file Excel đính kèm, có thay đổi dữ liệu). (Nếu muốn có thêm cột thứ tự thì cháu tạo ra 1 mảng RArr3 rồi gán vào vị trí cần gán vị trí cần)
Cháu cảm ơn các bác đã giúp cháu bài này trong chiều hôm nay.

Nếu kết quả là 2 cột kế nhau (F và G) thì mắc gì phải tạo 2 RArr? Sao không tạo RArr 2 cột? Trừ khi mỗi kết quả nằm 1 nơi mới cần nhiều mảng kết quả.
Code chỉnh sửa từ bạn @huuthang_bd đã chạy được đâu?

 

[huuthang_bd]

Nếu kết quả là 2 cột kế nhau (F và G) thì mắc gì phải tạo 2 RArr? Sao không tạo RArr 2 cột? Trừ khi mỗi kết quả nằm 1 nơi mới cần nhiều mảng kết quả.
Code chỉnh sửa từ bạn @huuthang_bd đã chạy được đâu?

Bài #16 chỉ đánh dấu chỗ sai chứ chưa sửa.

 

[Cô Bé Dễ Thương]

Nếu kết quả là 2 cột kế nhau (F và G) thì mắc gì phải tạo 2 RArr? Sao không tạo RArr 2 cột? Trừ khi mỗi kết quả nằm 1 nơi mới cần nhiều mảng kết quả.
Code chỉnh sửa từ bạn @huuthang_bd đã chạy được đâu?

Bài #16 chỉ đánh dấu chỗ sai chứ chưa sửa.

Các bác ăn tối chưa ạ.
Khi làm xong bài code bài #17 thấy kiến thức về mảng chưa có gì? Bó buộc khi dùng Dict.
Nãy cháu có sửa nhưng không đc mới nảy ra cái code ở bài #17. Hai vấn đề này cháu hi vọng ngâm cứu về mảng thêm tuần nữa mới mong giải quyết đc.
Cháu xin được chỉ dạy. Cháu xin khất ạ!

 

[huuthang_bd]

Chỗ màu đỏ trong bài #16 sửa thành SData là xong. Tôi đã chỉ chỗ sai rồi, chỉ cần so sánh với các code khác là biết sửa như thế nào thôi.

 

[ptm0412]

Bài #16 chỉ đánh dấu chỗ sai chứ chưa sửa.

Tôi viết là "chỉnh sửa từ bạn @huuthang_bd" nghĩa là chỉnh sửa từ "gợi ý" của bạn @huuthang_bd
Bạn đánh dấu chỗ sai, nhưng toàn bộ code là tự viết/ và chỉnh sửa từ code gợi ý/ hướng dẫn của bạn trong bài 14. Trong đó có nhiều chỗ sai ngoại trừ chỗ đỏ bạn đánh dấu:
- Code bạn gợi ý cho bài #1 nhưng xài cho file bài 17, mà bài 17 chèn thêm cột kết quả G nên bị lệch cột.
- Lệch luôn cả chỗ SampleArr = Range("o5:r8"), gốc gợi ý là Range("Q5:Q8"). Sau khi chèn cột đáng lẽ là R5:R8

 

[huuthang_bd]

@emgaimuarao Tôi thêm nhiều cột cần lấy để bạn thấy sự khác biệt. Muốn vận dụng được thì bạn phải nghiên cứu để hiểu code chứ sửa theo kiểu hên xui may rủi thì nguy hiểm quá.

Sub CheckNote_All_BAC_huuthang_bd()
Dim Dict, SData As Range, RArr(), Sample As Range, SampleArr As Variant
Dim i As Long, j As Long, k As Long
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("O5:Q8")
SampleArr = Range("R5:W8").Value 'Muon them/bot cot chi can sua cho nay
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, i
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 1 To UBound(SampleArr, 2))
For i = 1 To DataRows
    sKey = SData(i, 1).Interior.Color & _
    "|" & SData(i, 2).Interior.Color & _
    "|" & SData(i, 3).Interior.Color
    If Dict.exists(sKey) Then
        k = Dict.Item(sKey)
        For j = 1 To UBound(SampleArr, 2)
            RArr(i, j) = SampleArr(k, j)
            RArr(i, j) = SampleArr(k, j)
        Next
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 2)).Value = RArr
End Sub

 

[Cô Bé Dễ Thương]

@emgaimuarao Tôi thêm nhiều cột cần lấy để bạn thấy sự khác biệt. Muốn vận dụng được thì bạn phải nghiên cứu để hiểu code chứ sửa theo kiểu hên xui may rủi thì nguy hiểm quá.

Sub CheckNote_All_BAC_huuthang_bd()
Dim Dict, SData As Range, RArr(), Sample As Range, SampleArr As Variant
Dim i As Long, j As Long, k As Long
Dim LastRw As Long, sKey As String, DataRows As Long
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("O5:Q8")
SampleArr = Range("R5:W8").Value 'Muon them/bot cot chi can sua cho nay
For i = 1 To Sample.Rows.Count
    sKey = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey, i
Next
LastRw = Cells(1000, 2).End(xlUp).Row
Set SData = Range("C5:E" & LastRw)
DataRows = SData.Rows.Count
ReDim RArr(1 To DataRows, 1 To UBound(SampleArr, 2))
For i = 1 To DataRows
    sKey = SData(i, 1).Interior.Color & _
    "|" & SData(i, 2).Interior.Color & _
    "|" & SData(i, 3).Interior.Color
    If Dict.exists(sKey) Then
        k = Dict.Item(sKey)
        For j = 1 To UBound(SampleArr, 2)
            RArr(i, j) = SampleArr(k, j)
            RArr(i, j) = SampleArr(k, j)
        Next
    End If
Next
Range("F5").Resize(UBound(RArr, 1), UBound(SampleArr, 2)).Value = RArr
End Sub

Cháu cảm ơn ạ, cháu vẫn đang học nhưng không được nhanh. Thiếu cú pháp và lý luận về mảng nên hiện nay làm gì vẫn mò mò thấy giống rồi thử áp dụng.

 

[ptm0412]

@emgaimuarao Tôi thêm nhiều cột cần lấy để bạn thấy sự khác biệt. Muốn vận dụng được thì bạn phải nghiên cứu để hiểu code chứ sửa theo kiểu hên xui may rủi thì nguy hiểm quá.

Code dư 1 câu lệnh (2 câu giống hệt nhau)

Tuy nhiên điều đó không quan trọng.
Còn nữa, đối với trình độ bạn này thì tôi thường viết code đơn giản hết mức có thể.
- Code gợi ý bài 14 Redim (..., 0 to UBound(SampleArr, 1)) là quá sức với bạn ấy, tôi sẽ viết 1 to UBound(SampleArr, 1) +1, hoặc dùng 1 biến lấy giá trị "số dòng của sample Arr" với tên gợi hình gợi thanh gợi ý. Vậy mà chưa chắc thủng nữa là
- Code gợi ý bài 23 nếu là tôi thì cũng dùng 1 biến "số cột của SampleArr"
Đối với đầu vịt thì không đổ nước thông thường mà phải đổ nước ... sôi, quên, nước hoa

 

[Cô Bé Dễ Thương]

Code dư 1 câu lệnh (2 câu giống hệt nhau)
View attachment 254942
Tuy nhiên điều đó không quan trọng.
Còn nữa, đối với trình độ bạn này thì tôi thường viết code đơn giản hết mức có thể.
- Code gợi ý bài 14 Redim (..., 0 to UBound(SampleArr, 1)) là quá sức với bạn ấy, tôi sẽ viết 1 to UBound(SampleArr, 1) +1, hoặc dùng 1 biến lấy giá trị "số dòng của sample Arr" với tên gợi hình gợi thanh gợi ý. Vậy mà chưa chắc thủng nữa là
- Code gợi ý bài 23 nếu là tôi thì cũng dùng 1 biến "số cột của SampleArr"
Đối với đầu vịt thì không đổ nước thông thường mà phải đổ nước ... sôi, quên, nước hoa

- Bài giải có nhiều cách mới thấm chú Mỹ ạ. Nhiều cách giải của 1 bài thì lại được học thêm cú pháp và lý luận. Dòng lệnh nào nhiều kiến thức mà được thêm comment nữa thì quá tuyệt vời ạ.
- Bài #17 là cháu có nghĩ tới code của bác @VetMini bên thớt khác, chứ không phải đoán mà đâu ạ.
- Trước bài #23 cháu nãy thử lại và kiểm tra không chạy được, giờ so sánh thấy trình chưa đủ để bù những chỗ thiếu.

 

[huuthang_bd]

Còn nữa, đối với trình độ bạn này thì tôi thường viết code đơn giản hết mức có thể.

Em thì nghĩ thói quen và phong cách viết code sẽ dần hình thành ngay từ lúc bắt đầu tập viết code. Vì vậy cứ chia sẻ những gì mình cho là tốt.

 

[Cô Bé Dễ Thương]

Cháu có dạng chưa biết cú pháp để đưa giá trị là Key trong Dic ra ngoài bảng tính.
Xin chú Mỹ, cô bác giúp và anh chị giúp cháu phần cú pháp và lý luận này với ạ!
(Cụ thể file đính kèm và phần Code cháu đang làm dở ạ)

Sub chontheodieukien()
Dim Dict, SData As Range, RArr(), Sample As Range
Dim LastRw As Long, sKey_1 As String, sKey_2 As String, DataRows As Long
LastRw = Application.WorksheetFunction.CountA(Sheets("Sheet1").Range("B:B")) - 3
Set Dict = CreateObject("Scripting.Dictionary")
Set Sample = Range("C5:E" & LastRw + 4)
For i = 1 To Sample.Rows.Count
    a = Sample(i, 1).Interior.Color
    b = Sample(i, 2).Interior.Color
    c = Sample(i, 3).Interior.Color

    If (a = b And b = c) Then
    sKey_1 = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey_1, i
    End If

    If (a <> b And b = c) Then
    sKey_2 = Sample(i, 1).Interior.Color & _
    "|" & Sample(i, 2).Interior.Color & _
    "|" & Sample(i, 3).Interior.Color
    Dict.Add sKey_2, i
    End If
Next i
'......................
Với mỗi 1 If-End If ở trên cháu đã Add được sKey_1 và sKey_2 vào Dict
Xin cho cháu xin phần code  để đưa giá trị toàn bộ Key có trong Dict
Ra vị trí bắt đầu tờ H5
'......................
End Sub

 

[ptm0412]

- Tìm LastRw sao không tìm bằng End(xlUp)?
- Có lastRw sao không gán vào Range dữ liệu?
- Sao Range dữ liệu đặt tên là Sample (mẫu)?
- Sao lại gán j +4? j không khai báo và có biết j bằng bao nhiêu không?
- Dict.Add sKey_2: Có thử dò sKey_2 bằng cái gì chưa?
- cả 2 trường hợp add chung vào 1 Dict rồi làm sao tách ra?

 

[Cô Bé Dễ Thương]

- Tìm LastRw sao không tìm bằng End(xlUp)?
- Có lastRw sao không gán vào Range dữ liệu?
- Sao Range dữ liệu đặt tên là Sample (mẫu)?
- Sao lại gán j +4? j không khai báo và có biết j bằng bao nhiêu không?
- Dict.Add sKey_2: Có thử dò sKey_2 bằng cái gì chưa?
- cả 2 trường hợp add chung vào 1 Dict rồi làm sao tách ra?

- Tìm LastRw sao không tìm bằng End(xlUp)? TL: Cháu khống chế định dạng tiêu đề chung các Sheets lên kiểm soát được ạ.
- Có lastRw sao không gán vào Range dữ liệu? TL: Do sơ xuất nên chưa sửa hết ạ
- Sao Range dữ liệu đặt tên là Sample (mẫu)? TL: Vì lúc này bài toán chỉ trơ trọi 1 Bảng dữ liệu ạ
- Sao lại gán j +4? j không khai báo và có biết j bằng bao nhiêu không? TL: cháu quên chưa thay LastRw = j, copy lại code trước đang làm lên quên chỗ đó ạ
- Dict.Add sKey_2: Có thử dò sKey_2 bằng cái gì chưa? TL: Ngược lại thì sử dụng các code trước của Chú là tách được ạ. Các bài trước đây là dùng Key để tra ra Item, giờ là trường hợp khác. Lợi dụng Key là duy nhất để lọc ạ
Cháu vừa mò được đoạn:

'........
s = Dict.Count
Sheet1.[h5].Resize(s, 3) = Application.Transpose(Dict.keys)
'.....

Mà chạy chưa đúng ạ.
Giờ Add sKye_1, Add Kye_2 vào Dict rồi. Làm sao để dán các Key này xuống Dict. Giúp cháu với!

 

[ptm0412]

- Đọc kỹ code lại đi: câu lệnh nào gán j = CountA?
- Trơ trọi 1 bảng dữ liệu thí chính nó là dữ liệu, là Data chứ mẫu gì (sample = mẫu)
- Đọc kỹ câu lệnh nào tính sKey_2? Chả có câu nào, sKey_2 = null
- sKey_1 cũng add và item là i, sKey_2 cũng item là i, có mà giời tách

 

[Cô Bé Dễ Thương]

- Đọc kỹ code lại đi: câu lệnh nào gán j = CountA?
- Trơ trọi 1 bảng dữ liệu thí chính nó là dữ liệu, là Data chứ mẫu gì (sample = mẫu)
- Đọc kỹ câu lệnh nào tính sKey_2? Chả có câu nào, sKey_2 = null
- sKey_1 cũng add và item là i, sKey_2 cũng item là i, có mà giời tách

- Cháu nghĩ: Vùng cháu chọn cháu biết chắc là có sKye_1, sKey_2 tồn tại. Khi cháu đưa If-End If vào thì nó sẽ lọc theo điều kiên a,b,c để có tập Key. Khi có tập Key cháu dán xuống Sheet
- tạo 1 Key và tìm Item của nó các bài trước cũng hòm hòm rồi ạ
- Giờ tạo hai Key và lấy tập Key thì chưa biết ạ? Không biết bài #30 có làm như cháu nghĩ được không chú? Hay buộc phải có biện pháp khác ạ?

 

[ptm0412]

- Cháu nghĩ: Vùng cháu chọn cháu biết chắc là có sKye_1, sKey_2 tồn tại. Khi cháu đưa If-End If vào thì nó sẽ lọc theo điều kiên a,b,c để có tập Key. Khi có tập Key cháu dán xuống Sheet
- tạo 1 Key và tìm Item của nó các bài trước cũng hòm hòm rồi ạ
- Giờ tạo hai Key và lấy tập Key thì chưa biết ạ? Không biết bài #30 có làm như cháu nghĩ được không chú? Hay buộc phải có biện pháp khác ạ?

Chán quá đi à.
- Câu lệnh là LastRw = ... CountA chứ có phải j = CountA đâu?
- Câu lệnh là
sKey_1 = ...
Dict.Add sKey_2, i
chứ có phải sKey_2 đâu mà gán sKey_2?
- item của cả 2 loại màu là i, là STT dòng của range dữ liệu có xài được cho Bảng 2 đâu? chả lẽ bảng 2 rời rạc?
- đã tính a, b, c rồi mà 2 cái sKey lại phải tính lại lần nữa?

Tất cả các câu hỏi trên nhằm mục đích mắng cho cái chuyện copy code của người khác từng câu từng câu về mà không biết nó ra kết quả gì, thậm chí copy dòng trên xuống dòng dưới mà sửa không rốt ráo.
Phướng pháp là các bước thế này:
1. Tự suy nghĩ về thuật toán (cái gọi là ní nuận ấy)
2. Ghi ra giấy, nghĩ lại lần nữa, sắp xếp lại nếu cần
3. Tự viết câu lệnh dựa vào ní nuận đã ghi trên giấy, không copy từng dòng lệnh của người khác, trừ khi biết chính xác là câu lệnh copy đó phù hợp với ní nuận
4. Viết xong chạy thử từng dòng lệnh: Nhấn F8 để chạy từng câu lệnh.
- Sau mỗi câu lệnh, rà chuột vào các biến để xem giá trị tức thời của biến (chỉ xem được biến đơn, không xem được biến mảng hoặc giá trị mảng, giá trị range nhiều ô).
- Đối chiếu với giá trị mong muốn
- Nếu code có cấu trúc If, thì xem lệnh chạy đến điều kiện của If rồi chạy thẳng đến else, hay chạy các dòng lệnh của if? Việc này đúng hay sai so với mong muốn?
- Nếu có vòng lặp, thì xét ít nhất 3 vòng lặp xem các câu lệnh có chạy đúng ý muốn chưa

Đối với bài này:
- xác định ý muốn là gì: Liệt kê riêng 3 màu giống nhau và 2 màu cuối giống nhau, hay liệt kê riêng 2 bảng. Liệt kê chung thì mới bỏ chung vào 1 Dict
- Xác định là mỗi bộ màu thoả điều kiện chỉ liệt kê 1 lần, hay liệt kê hết? (thí dụ có 3 dòng đều có 3 ô màu đỏ thì liệt kê 1 lần hay 3 lần). Nếu chỉ liệt kê 1 lần mới xài Dict
- đặt 3 biến a, b, c để lấy 3 già trị màu, ok. Vậy thì các sKey nối a, b, c chứ mắc gì nối lại 3 lần tìm giá trị màu? Cái này rõ ràng là làm biếng viết, nghĩ rồi mà không viết, lại đi copy. Rồi rõ ràng mu61n add sKey_2, mà lại copy câu lệnh của sKey_1 xuống, không sửa 1 thành 2!
- Vòng lặp i chạy qua vùng dữ liệu, vậy i có xài được cho bảng kết quả không? Nếu không thì gán item là i làm cái quái gì.
- Kết quả là cần màu, chứ có cần key hay item đâu mà transpose? Phải dùng kết quả a, b, c là giá trị màu, gán màu vào bảng 2.
- Nếu gán màu xuống bảng 2 thì phải có biến dòng cho bảng 2, mỗi lần ghi màu là tăng lên 1, chứ không là ghi đè vào dòng cũ.

Mắng cũng bắt mệt rồi đa!

 

[Cô Bé Dễ Thương]

Chán quá đi à.
- Câu lệnh là LastRw = ... CountA chứ có phải j = CountA đâu?
- Câu lệnh là
sKey_1 = ...
Dict.Add sKey_2, i
chứ có phải sKey_2 đâu mà gán sKey_2?
- item của cả 2 loại màu là i, là STT dòng của range dữ liệu có xài được cho Bảng 2 đâu? chả lẽ bảng 2 rời rạc?
- đã tính a, b, c rồi mà 2 cái sKey lại phải tính lại lần nữa?

Tất cả các câu hỏi trên nhằm mục đích mắng cho cái chuyện copy code của người khác từng câu từng câu về mà không biết nó ra kết quả gì, thậm chí copy dòng trên xuống dòng dưới mà sửa không rốt ráo.
Phướng pháp là các bước thế này:
1. Tự suy nghĩ về thuật toán (cái gọi là ní nuận ấy)
2. Ghi ra giấy, nghĩ lại lần nữa, sắp xếp lại nếu cần
3. Tự viết câu lệnh dựa vào ní nuận đã ghi trên giấy, không copy từng dòng lệnh của người khác, trừ khi biết chính xác là câu lệnh copy đó phù hợp với ní nuận
4. Viết xong chạy thử từng dòng lệnh: Nhấn F8 để chạy từng câu lệnh.
- Sau mỗi câu lệnh, rà chuột vào các biến để xem giá trị tức thời của biến (chỉ xem được biến đơn, không xem được biến mảng hoặc giá trị mảng, giá trị range nhiều ô).
- Đối chiếu với giá trị mong muốn
- Nếu code có cấu trúc If, thì xem lệnh chạy đến điều kiện của If rồi chạy thẳng đến else, hay chạy các dòng lệnh của if? Việc này đúng hay sai so với mong muốn?
- Nếu có vòng lặp, thì xét ít nhất 3 vòng lặp xem các câu lệnh có chạy đúng ý muốn chưa

Đối với bài này:
- xác định ý muốn là gì: Liệt kê riêng 3 màu giống nhau và 2 màu cuối giống nhau, hay liệt kê riêng 2 bảng. Liệt kê chung thì mới bỏ chung vào 1 Dict
- Xác định là mỗi bộ màu thoả điều kiện chỉ liệt kê 1 lần, hay liệt kê hết? (thí dụ có 3 dòng đều có 3 ô màu đỏ thì liệt kê 1 lần hay 3 lần). Nếu chỉ liệt kê 1 lần mới xài Dict
- đặt 3 biến a, b, c để lấy 3 già trị màu, ok. Vậy thì các sKey nối a, b, c chứ mắc gì nối lại 3 lần tìm giá trị màu? Cái này rõ ràng là làm biếng viết, nghĩ rồi mà không viết, lại đi copy. Rồi rõ ràng mu61n add sKey_2, mà lại copy câu lệnh của sKey_1 xuống, không sửa 1 thành 2!
- Vòng lặp i chạy qua vùng dữ liệu, vậy i có xài được cho bảng kết quả không? Nếu không thì gán item là i làm cái quái gì.
- Kết quả là cần màu, chứ có cần key hay item đâu mà transpose? Phải dùng kết quả a, b, c là giá trị màu, gán màu vào bảng 2.
- Nếu gán màu xuống bảng 2 thì phải có biến dòng cho bảng 2, mỗi lần ghi màu là tăng lên 1, chứ không là ghi đè vào dòng cũ.

Mắng cũng bắt mệt rồi đa!

- Vâng cháu sơ suất mất tập chung chỗ đấy thành ra hành chú mất rồi. Hic hic xót chú.
- Bài #30 cháu muốn liệt kê 2 trường hợp chung 1 bảng và 1 lần. Thí dụ có 3 dòng đều có 3 ô màu đỏ thì chỉ liệt kê 1 lần.(1 trường hợp cháu làm ngon)
Không biết bài #30 tạo ra nhiều Key cùng 1 Sub rồi lấy tất cả các Key ra đươc không chú nhỉ?

 

[ptm0412]

- Vâng cháu sơ suất mất tập chung chỗ đấy thành ra hành chú mất rồi. Hic hic xót chú.
- Bài #30 cháu muốn liệt kê 1 lần. Thí dụ có 3 dòng đều có 3 ô màu đỏ thì chỉ liệt kê 1 lần.
Không biết bài #30 tạo ra nhiều Key cùng 1 Sub rồi lấy tất cả các Key ra đươc không chú nhỉ?

Đã nói là không cần lấy key, lấy a, b, c gắn màu cho 1 dòng của bảng 2. Nhớ thêm 1 biến dòng tăng cho bảng 2.
Key là chuỗi dài ngoằng đó xài gì được cho việc gan màu.

 

[Cô Bé Dễ Thương]

Đã nói là không cần lấy key, lấy a, b, c gắn màu cho 1 dòng của bảng 2. Nhớ thêm 1 biến dòng tăng cho bảng 2.
Key là chuỗi dài ngoằng đó xài gì được cho việc gan màu.

Vâng ạ. Để mai cháu làm lại 2 gạch đầu dòng dưới đây.
- Giải kiểu range("H5") = a, lúc đó cháu đoán mò là nó sẽ liệt kê tất cả, mà trong khi đó cháu cần điểm danh 1 lần. Chung vào một bảng.
- Mà dùng dictionary với 1 key cháu làm được từng trường hợp ngon. Nhưng trên sheet lại thêm cột kết quả.

 

[ptm0412]

- Giải kiểu range("H5") = a,

Cần gán màu hay cần gán giá trị màu mà "giải kiểu" này?

 

[Cô Bé Dễ Thương]

Cần gán màu hay cần gán giá trị màu mà "giải kiểu" này?

- Gán màu ạ. Cụ thể khi gán là Range("H5").Interior.Color = RGB(r,g,b) ạ. Lúc đó tô màu đc 1 ô H5. Cứ If-End If là tô theo ý mình đc ạ.
- Và rắc rồi bắt đàu từ ý muốn 2 Sub thành 1 Sub và 2 bảng kết quả chung 1 bảng. Lúc đó lại khóc rồi hic
Thấy chú còn xanh xanh, cháu thử làm theo cách Dict chú coi qua cháu với nhé. Có giải theo Dictionary. file đính kèm rồi ạ

Bài #30 hiện cháu giải theo cách này mà vẫn dùng Dict. Nhưng nó nảy sinh vẫn đề là phát sinh nhiều Sub và nhiều bảng kết quả nếu có nhiều trường hợp.
Vì đang học Dictionary nên cháu muốn giải theo hướng này.
Mong muốn: Gộp tất cả các trường hợp vào chúng 1 Sub và kết xuất ra chung 1 bảng

 

[ptm0412]

Thấy chú còn xanh xanh,

Xanh thì xanh chứ, đến giờ ăn khuya để uống thuốc ai mà ngồi mãi.
Do cần liệt kê chỉ 1 lần cho mỗi bộ nên vẫn dùng Dict.
Đã nói rồi, không cần xài chuỗi key dài ngoằng mà cứ xài, đã bảo xài a, b, c đi mà không xài (2 chỗ)

Sub Filter_1()
Dim dict, ki, k
Set dict = CreateObject("Scripting.Dictionary")
k = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If (a = b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    End If
Next rg
End Sub

Code gộp ra 2 bảng:

Sub Filter_2Type()
Dim dict, ki, k, m
Set dict = CreateObject("Scripting.Dictionary")
k = 4: m = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If (a = b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    ElseIf (a <> b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            m = m + 1
            dict.Add ki, m
            Cells(m, 11).Interior.Color = a
            Cells(m, 12).Interior.Color = b
            Cells(m, 13).Interior.Color = c
        End If
    End If
Next rg
End Sub

Còn sub Delete đọc thấy gớm, giống record macro sao để vậy

Sub DELETE()
    Range("G5:M1000").ClearFormats
End Sub

 

[Cô Bé Dễ Thương]

Xanh thì xanh chứ, đến giờ ăn khuya để uống thuốc ai mà ngồi mãi.
Do cần liệt kê chỉ 1 lần cho mỗi bộ nên vẫn dùng Dict.
Đã nói rồi, không cần xài chuỗi key dài ngoằng mà cứ xài, đã bảo xài a, b, c đi mà không xài (2 chỗ)

Sub Filter_1()
Dim dict, ki, k
Set dict = CreateObject("Scripting.Dictionary")
k = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If (a = b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    End If
Next rg
End Sub

Code gộp ra 2 bảng:

Sub Filter_2Type()
Dim dict, ki, k, m
Set dict = CreateObject("Scripting.Dictionary")
k = 4: m = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If (a = b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    ElseIf (a <> b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            m = m + 1
            dict.Add ki, m
            Cells(m, 11).Interior.Color = a
            Cells(m, 12).Interior.Color = b
            Cells(m, 13).Interior.Color = c
        End If
    End If
Next rg
End Sub

Còn sub Delete đọc thấy gớm, giống record macro sao để vậy

Sub DELETE()
    Range("G5:M1000").ClearFormats
End Sub

Chú thức muộn quá.
Do hay phải thức đêm nhiều nên cháu đang sợ vấn đề dạ dày về sau, mà hay lo nghĩ, hoặc lắm thứ phải nghĩ thì rất hại dạ dày. Cháu bị hay bị ợ hơi, dùng nano nghệ thấy đỡ.
Trong 2 code trên cháu chưa hiểu:
1, k = 4
2, k = 4: m = 4
3, Cell(k, 7 hoặc 8 hoặc 9) hay Cell(m, 11 hoặc 12 hoặc 13)
Làm sao xác đinh được các giá trị m, k và chỉ số cột có trong Cell ạ.
Code ở dưới tên Sub Filter_2Type() là gộp 2 trương hợp thành 1 Sub, nhưng kết quả vẫn cho ra 2 bảng. Cháu muốn chú giúp cho thành 1 bảng kết quả chung của 2 trường hơp ạ

Sub Filter_2Type()
Dim dict, ki, k, m
Set dict = CreateObject("Scripting.Dictionary")
k = 4: m = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If (a = b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    ElseIf (a <> b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            m = m + 1
            dict.Add ki, m
            Cells(m, 11).Interior.Color = a
            Cells(m, 12).Interior.Color = b
            Cells(m, 13).Interior.Color = c
        End If
    End If
Next rg
End Sub

 

[ptm0412]

1, k = 4
2, k = 4: m = 4
3, Cell(k, 7 hoặc 8 hoặc 9) hay Cell(m, 11 hoặc 12 hoặc 13)
Làm sao xác đinh được các giá trị m, k và chỉ số cột có trong Cell ạ.

- k và m là 2 biến ghi nhận dòng tăng dần để khỏi ghi đè (nói rồi)
- Nếu không gán trước 1 giá trị thì nó bằng 0, null, hoặc nothing tuỳ theo kiểu biến. Do nó sẽ tăng 1 và muốn dòng ghi đầu tiên là dòng 5 thì phải gán cho nó bằng 4 trước
- 7, 8, 9, 11, 12, 13 là lấy ngón tay đếm trên màn hình số thứ tự của 6 cột của 2 bảng kết quả

 

[Cô Bé Dễ Thương]

- k và m là 2 biến ghi nhận dòng tăng dần để khỏi ghi đè (nói rồi)
- Nếu không gán trước 1 giá trị thì nó bằng 0, null, hoặc nothing tuỳ theo kiểu biến. Do nó sẽ tăng 1 và muốn dòng ghi đầu tiên là dòng 5 thì phải gán cho nó bằng 4 trước
- 7, 8, 9, 11, 12, 13 là lấy ngón tay đếm trên màn hình số thứ tự của 6 cột của 2 bảng kết quả

- Vâng. Cái 7, 8, 9, 11, 12, 13 cháu cũng nghĩ là cột tính từ vị trí vùng data.
- giờ mới hiểu được giá trị k, m này ở các code trước của chú.
- Kết quả cháu muốn là chung 1 bảng. Cháu đổi 11,12,13 thành 7 8 9 thì nó lại mất đi 1 trường hợp. Cụ thể như ảnh ạ!

Sau khi đổi 11 12 13 thành 7 8 9 để chung 1 bảng thì

Chưa biết thêm cái If-End If gì nữa để nó chạy ra kết quả chung 1 bảng ạ. Hiện cháu đổi m = 4 thành m = 1 ; m = k + m + 1. Và 11 12 13 thành 7 8 9 thì được kết quả mong muốn. Nhưng không biết vậy có đúng hay sai trong thuật toán này của chú ạ!

 

[ptm0412]

Cùng 1 bảng kết quả thì chỉ cần 1 biến k thôi, chán!
_____
Chưa thả tim mấy bài rồi kìa! Thức đêm thức hôm, nắn nót từng câu từng chữ mà không chịu đọc cho hết, tim cũng không thả

 

[Cô Bé Dễ Thương]

Cùng 1 bảng kết quả thì chỉ cần 1 biến k thôi, chán!
_____
Chưa thả tim mấy bài rồi kìa! Thức đêm thức hôm, nắn nót từng câu từng chữ mà không chịu đọc cho hết, tim cũng không thả

đổi m = 1 ở chỗ khai báo, rồi trong ElseIf thì đặt m = m + 1 + k thảo nào nó lại nó lại đúng. Qua bài này không hành chú đêm hôm nữa. Xót chú quá.
Cháu sửa chung biến k rồi ạ. Xinh ơi là xinh, đẹp quá!

Sub Filter_2Type()
Dim dict, ki, k, m
Set dict = CreateObject("Scripting.Dictionary")
'Bỏ m = 4, chỉ để k = 4
k = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If (a = b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    ElseIf (a <> b And b = c) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
        'Thêm k vào chỗ này nữa là ok
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Interior.Color = a
            Cells(k, 8).Interior.Color = b
            Cells(k, 9).Interior.Color = c
        End If
    End If
Next rg
End Sub

Cái que "|" này không biết gõ làm sao để có chú nhỉ? (Thôi cháu trốn thôi hic hic)

 

[Hoàng Tuấn 868]

Cái que "|" này không biết gõ làm sao để có

Bạn thử ấn phím "Shift" và phím "\" xem thế nào.

 

[Cô Bé Dễ Thương]

Bạn thử ấn phím "Shift" và phím "\" xem thế nào.

Thanh bác. Trước giờ toàn copy xuống để dùng hihi

 

[ptm0412]

Cháu sửa chung biến k rồi ạ. Xinh ơi là xinh, đẹp quá!

chung biến k, chung bảng kết quả, vậy thì if 1 lần thôi, khỏi else
if 3 màu or 2 màu then

 

[Cô Bé Dễ Thương]

chung biến k, chung bảng kết quả, vậy thì if 1 lần thôi, khỏi else
if 3 màu or 2 màu then

Đánh số thứ tự dựa vào m = dict.Count. Có ổn không ạ

 

[Cô Bé Dễ Thương]

chung biến k, chung bảng kết quả, vậy thì if 1 lần thôi, khỏi else
if 3 màu or 2 màu then

Ngon rồi ạ! Túc tắc vỡ vạc được nhiều thứ quá.

Sub Filter_2Type_FIX()
Dim dict, ki, k, m
Set dict = CreateObject("Scripting.Dictionary")
k = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If ((a = b And b = c) Or (a <> b And b = c)) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 8).Interior.Color = a
            Cells(k, 9).Interior.Color = b
            Cells(k, 10).Interior.Color = c
        End If
   End If
Next rg
m = dict.Count
For i = 1 To m
Range("G" & i + 4).Value = i
Next i
End Sub

 

[ptm0412]

Đánh số thứ tự dựa vào m = dict.Count. Có ổn không ạ

Nhìn thấy đúng, là đúng
nhưng đang có k = 5, 6, 7, 8, ... Sao không lấy k-4 bỏ vào cells(k, 6) luôn?

 

[Cô Bé Dễ Thương]

Nhìn thấy đúng, là đúng
nhưng đang có k = 5, 6, 7, 8, ... Sao không lấy k-4 bỏ vào cells(k, 6) luôn?

Có luôn ạ. Hay đến mức chưa hiểu ra vấn đề sao không dùng vòng lặp mà ra được ô Cell(k,7) = k-4 nó chạy như vòng lặp được ạ!
Chỉ hiểu được do biến rg nó chạy nó gán k tuần tự phải không ạ?
Nghỉ trưa ăn cơm chú nhỉ? Được đến đây là làm bài của mình phà phà rồi. Nhàn quá thu gọn cả 100 Sub thành 10 Sub, làm file excel nhẹ 9/10 rồi. Đến đây sảng khoái thật sự chú ạ! Cảm ơn chú rất nhiều! Ông bụt diễn đàn.

Sub Filter_2Type_FIX()
Dim dict, ki, k
Set dict = CreateObject("Scripting.Dictionary")
k = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If ((a = b And b = c) Or (a <> b And b = c)) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            'Sửa bài #49
            Cells(k, 7).Value = k - 4
            Cells(k, 8).Interior.Color = a
            Cells(k, 9).Interior.Color = b
            Cells(k, 10).Interior.Color = c
        End If
   End If
Next rg
End Sub

 

[Cô Bé Dễ Thương]

Thêm cột cộng dồn số lượng nếu trùng, có cho chung vào Sub này được không ạ? Hay phải tác ra viết riêng 1 Sub khác vậy chú Mỹ?
Cháu thứ mấy cú pháp học mót nhưng chưa ra được kết quả ạ!

Sub Filter_2Type_FIX()
Dim dict, ki, k
Set dict = CreateObject("Scripting.Dictionary")
k = 4
For Each rg In Range("C5:E19").Rows
    a = rg.Cells(1, 1).Interior.Color
    b = rg.Cells(1, 2).Interior.Color
    c = rg.Cells(1, 3).Interior.Color
    If ((a = b And b = c) Or (a <> b And b = c)) Then
        ki = a & "|" & b & "|" & c
        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            'Sửa bài #49
            Cells(k, 7).Value = k - 4
            Cells(k, 8).Interior.Color = a
            Cells(k, 9).Interior.Color = b
            Cells(k, 10).Interior.Color = c
           'Thêm cột cộng dồn số lượng nếu trùng, có cho chung vào Sub này được không ạ? Hay phải tác ra viết riêng 1 Sub khác vậy chú Mỹ?
           'Thứ mấy cú pháp học mót nhưng chưa ra được kết quả ạ!
            Cells(k, 11).Value = dict.Item(ki)
        End If
   End If
Next rg
End Sub

 

[ptm0412]

Cháu thứ mấy cú pháp học mót nhưng chưa ra được kết quả ạ!

Chủ nhật không hẹn hò, không cho con đi chơi hay sao mà ngồi đó vậy?
Cộng dồn là số cũ cộng thêm 1 giá trị nào đó thành số mới, chứ không cộng lấy gì mà dồn?
1. Cú pháp cộng dồn cho trường hợp dùng Dict và cộng dồn bằng item của Dict là:

If thoả điều kiện Then
    sKey = "..."
    If chưa có trong Dict
        Dict.Add sKey, 1 'hoặc số ban đầu'
        '...'
    Else
        Dict.(sKey) = Dict.sKey + 1 'hoặc số tăng theo mong muốn'
    End If
Else 'không thoả'
    '...'
End If

Sau đó lấy xuống sheet bằng cách transpose Dict.Items

Nếu cộng dồn bằng 1 cột trong ResultArr thì phải có câu
ResultArr(m, n) = ResultArr(m, n) + ...
2. Trong bài này có thể ghi đè lên ô cũ:

        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Value = k - 4
            Cells(k, 8).Interior.Color = a
            Cells(k, 9).Interior.Color = b
            Cells(k, 10).Interior.Color = c
            Cells(k, 11) = 1
        Else
            Cells(Dict(ki),11) = Cells(Dict(ki),11) + 1
        End If

 

[Cô Bé Dễ Thương]

Chủ nhật không hẹn hò, không cho con đi chơi hay sao mà ngồi đó vậy?
Cộng dồn là số cũ cộng thêm 1 giá trị nào đó thành số mới, chứ không cộng lấy gì mà dồn?
1. Cú pháp cộng dồn cho trường hợp dùng Dict và cộng dồn bằng item của Dict là:

If thoả điều kiện Then
    sKey = "..."
    If chưa có trong Dict
        Dict.Add sKey, 1 'hoặc số ban đầu'
        '...'
    Else
        Dict.(sKey) = Dict.sKey + 1 'hoặc số tăng theo mong muốn'
    End If
Else 'không thoả'
    '...'
End If

Sau đó lấy xuống sheet bằng cách transpose Dict.Items

Nếu cộng dồn bằng 1 cột trong ResultArr thì phải có câu
ResultArr(m, n) = ResultArr(m, n) + ...
2. Trong bài này có thể ghi đè lên ô cũ:

        If Not dict.exists(ki) Then
            k = k + 1
            dict.Add ki, k
            Cells(k, 7).Value = k - 4
            Cells(k, 8).Interior.Color = a
            Cells(k, 9).Interior.Color = b
            Cells(k, 10).Interior.Color = c
            Cells(k, 11) = 1
        Else
            Cells(Dict(ki),11) = Cells(Dict(ki),11) + 1
        End If

Nhân ngày 8/3 chúc mừng cô ạ
Được cách làm và cú pháp thế này, chắc cháu mò được rồi ạ.
Giờ chỉ mong có nhiều thời gian ngồi mò mẫm thôi chú ạ.

 

[ptm0412]

Nhân ngày 8/3 chúc mừng cô ạ

Cô nào mà cô hả trời?

 

[Cô Bé Dễ Thương]

Cô nào mà cô hả trời?

Cô là bà ngoại của cháu ngoại chú ý. Chết dở hihi
Chú có tặng bông cô chưa?
Chập tối cơm xong sửa lại hết bộ file excel của cháu theo code mới chạy tít thật. Giờ cháu nghiện món VBA này rồi, thèm cái cảm giác chỉ bàn về tốc độ code, chắc sướng phải biết.
Chú uống thuốc đi nghỉ sớm đi chú ạ. Tối nào trc khi ngủ cháu cũng làm cốc nghệ. Thế mới có sức hành chú.

 

[ptm0412]

Cô là bà ngoại của cháu ngoại chú ý. Chết dở hihi
Chú có tặng bông cô chưa ạ?

Chú đi ún rụ với bạn bè còn phải xin tiền bà í, có đâu tiền trong túi mà tặng bông.
Tặng bông 1 phát là lãnh đủ ngay:
- Có quỹ đen hả?
- Ngày 8/3 là cái quái gì? Một năm đủ 365 ngày cho tôi!
Dám trả lời là đi đếm rễ giá hoặc chia lá hành làm 20 khúc đều nhau ngay

 

[Cô Bé Dễ Thương]

Chú đi ún rụ với bạn bè còn phải xin tiền bà í, có đâu tiền trong túi mà tặng bông.
Tặng bông 1 phát là lãnh đủ ngay:
- Có quỹ đen hả?
- Ngày 8/3 là cái quái gì? Một năm đủ 365 ngày cho tôi!
Dám trả lời là đi đếm rễ giá hoặc chia lá hành làm 20 khúc đều nhau ngay

Khéo cô đang ở sau lưng thì...
Mà cô để chú thức muộn vậy. Đi nghỉ sớm đi chú ơi.

Bài đã được tự động gộp: 7/3/21