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

Liên hệ QC

Cô Bé Dễ Thương

Thành viên thường trực
Tham gia
30/9/16
Bài viết
223
Được thích
48
Giới tính
Nữ
phu.jpg
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)
 

File đính kèm

  • dienten.xlsm
    25 KB · Đọc: 10
Lần chỉnh sửa cuối:
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ả
 
Upvote 0
- 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 ạ!
chung.jpg
Sau khi đổi 11 12 13 thành 7 8 9 để chung 1 bảng thì
chiem.png
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ú ạ!
dc.jpg
 
Lần chỉnh sửa cuối:
Upvote 0
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ả
 
Upvote 0
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á!
PHP:
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)
 

File đính kèm

  • chontheodk.xlsm
    48.5 KB · Đọc: 5
Lần chỉnh sửa cuối:
Upvote 0
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á.
PHP:
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
 
Upvote 0
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.
PHP:
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
 
Lần chỉnh sửa cuối:
Upvote 0
congdon.jpg
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ả ạ!
PHP:
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
 
Upvote 0
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à:
PHP:
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ũ:

PHP:
        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
 
Lần chỉnh sửa cuối:
Upvote 0
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à:
PHP:
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ũ:

PHP:
        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ú ạ.
 
Upvote 0
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ú.
 
Lần chỉnh sửa cuối:
Upvote 0
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
 
Upvote 0
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:
 
Upvote 0
Web KT
Back
Top Bottom