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:
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)
PHP:
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
 
Upvote 0
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)
PHP:
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
PHP:
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
 
Lần chỉnh sửa cuối:
Upvote 0
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)
 
Upvote 0
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:
ten2.jpg
 
Upvote 0
Upvote 0
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).
 
Lần chỉnh sửa cuối:
Upvote 0
1 cách cù lần này để bạn tham khảo:
PHP:
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
 
Upvote 0
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
 
Lần chỉnh sửa cuối:
Upvote 0
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 ạ!
 
Lần chỉnh sửa cuối:
Upvote 0
- 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ị ...
 
Upvote 0
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:

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
 
Lần chỉnh sửa cuối:
Upvote 0
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.
Mã:
'...
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
 
Upvote 0
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.
Mã:
'...
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
PHP:
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 ạ?
 
Upvote 0
Sai chỗ màu đỏ.
Rich (BB code):
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
 
Upvote 0
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.
1614938259721.png
PHP:
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:

Sai chỗ màu đỏ.
Rich (BB code):
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 ạ!
 

File đính kèm

  • dienten_dafix.xlsm
    29 KB · Đọc: 4
Lần chỉnh sửa cuối:
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
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 ạ!
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT
Back
Top Bottom