điền màu tự động vào ô trong excel (1 người xem)

  • Thread starter Thread starter kute2007
  • Ngày gửi Ngày gửi
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)
K

kute2007

Thành viên chính thức
Tham gia
17/11/08
Bài viết
70
Được thích
0
E có một bài toán thế này , mong ace diễn đàn giúp e ạ.
----
E có một bảng gồm 7 màu khác nhau ( Bao gồm Yellow,light blue, gray, green, pink, ivory, red)
bài toán đặt ra là điền 7 màu trên vào 5 ô ( B15-F15) như file đính kèm
---
Thuật toán để điền màu vào 5 ô như sau:

B1: điền màu vàng ở ô số 1, và điền tất cả các khả năng xảy ra với 6 màu còn lại vào 4 ô còn lại.
B2: điền đồng thời màu vàng vào ô số 1 và 2, sau đó điền tất cả các khả năng xay ra với 6 màu còn lại với 3 ô còn lại
B3: điền đồng thời màu vàng vào ô số 1, 2 và 3, sau đó điền tất cả khả năng xảy ra với 6 màu còn lại ở 2 ô còn lại
B4: điền đồng thời màu vàng vào ô 1, 2, 3 và 4, sau đó điền tất cả các khả năng xảy ra với 6 màu còn lại ở 1 ô còn lại
B5: điền màu vàng ở tất cả 5 ô khi làm xong 4 bước trên.
B6: lập lại các bước 1,2,3,4,5 ở trên với các màu còn lại theo thứ tự. (light blue, gray, green, pink, ivory, red)

---
Minhoa.jpg
Mong ace giúp đỡ,
 

File đính kèm

Lần chỉnh sửa cuối:
kute2007 đã viết:
E có một bài toán thế này , mong ace diễn đàn giúp e ạ.
----
E có một bảng gồm 7 màu khác nhau ( Bao gồm mãu từ D0-D6)- Như hình
-
Bài toán đặt ra là điền tất cả các màu và trong 5 ô - E ký hiệu là ô số 1- số 2- số 3- số 4 - số 5.

Cách điền như sau:
Bước 1: Điền tất cả Màu D0 ở vị trí đầu tiên
Bước 2: điền tất cả Màu D0 ở vị trí đầu tiền và vị trí thứ 2
BƯớc 3: Ap dụng cách điền tương cho tới khi vị trí đầu và vị trí cuối đều có cùng màu D0
Bước 3: Lặp lại bước 1-bước 2-bước 3 cho màu D1-D2-D3-D4-D5-D6.
---
Nếu điền thủ công thì rất khó, nên e up lên diễn dần file , mong ace viết code giùm e ạ.
Em cảm ơn ace rất nhiều ,
Nhấp chuột vào đây để mở rộng...
Bạn giải thích rõ hơn được không? Mình vẫn chưa hiểu rõ ý bạn lắm!
 
kute2007 đã viết:
CÓ nghĩa là mình có 7 màu khác nhau, được ký hiệu là D0-...D6 . Như trên hình.
Giờ mình muốn điền các màu vào ô 1-2-3-4-5 theo phương pháp mình nói ở trên.
Nhấp chuột vào đây để mở rộng...
Bạn hãy xem lại bài trước khi gửi nhé! Tôi thấy giữa lời giải thích của bạn và phần minh họa mâu thuẫn(Chỗ in đậm) nên tôi mới bảo bạn giải thích lại.
kute2007 đã viết:
E có một bài toán thế này , mong ace diễn đàn giúp e ạ.
----
E có một bảng gồm 7 màu khác nhau ( Bao gồm mãu từ D0-D6)- Như hình
-
Bài toán đặt ra là điền tất cả các màu và trong 5 ô - E ký hiệu là ô số 1- số 2- số 3- số 4 - số 5.

Cách điền như sau:
Bước 1: Điền tất cả Màu D0 ở vị trí đầu tiên
Bước 2: điền tất cả Màu D0 ở vị trí đầu tiền và vị trí thứ 2
BƯớc 3: Ap dụng cách điền tương cho tới khi vị trí đầu và vị trí cuối đều có cùng màu D0
Bước 3: Lặp lại bước 1-bước 2-bước 3 cho màu D1-D2-D3-D4-D5-D6.
---
Nếu điền thủ công thì rất khó, nên e up lên diễn dần file , mong ace viết code giùm e ạ.
Em cảm ơn ace rất nhiều ,
Nhấp chuột vào đây để mở rộng...
 
chuot0106 đã viết:
Bạn hãy xem lại bài trước khi gửi nhé! Tôi thấy giữa lời giải thích của bạn và phần minh họa mâu thuẫn(Cỗ in đậm) nên tôi mới bảo bạn giải thích lại.
Nhấp chuột vào đây để mở rộng...
đó là cách để điền tất cả khả năng vào ô 1-2-3-4-5 bạn à.

đầu tiền sẽ điền tất cả khả năng của Màu D0 vào ô đầu tiên là ô 1, sau đó điền tiếp màu D0 vào ô 1 và ô 2.. cứ làm tương tự cho tới khi ô 1-2-3-4-5 đều có màu D0. CÁch điền tương tự cũng giống như Màu D1-D2-D3-D4-D5-D6
 
Mong các ace chỉ giúp e ạ
 
các ace cao thủ giúp e cách điền màu vào ô vuông ạ
 
kute2007 đã viết:
đó là cách để điền tất cả khả năng vào ô 1-2-3-4-5 bạn à.

đầu tiền sẽ điền tất cả khả năng của Màu D0 vào ô đầu tiên là ô 1, sau đó điền tiếp màu D0 vào ô 1 và ô 2.. cứ làm tương tự cho tới khi ô 1-2-3-4-5 đều có màu D0. CÁch điền tương tự cũng giống như Màu D1-D2-D3-D4-D5-D6
Nhấp chuột vào đây để mở rộng...
Tô tiếp vào vùng kết kết khoảng 10 hàng nữa xem sao vì đây là một dạng : "nhìn kết quả, đoán đề bài"
Những cell trong bảng tính có địa chỉ (hàng, cột) rõ ràng, bạn nên dùng nó, thí dụ [B16], [C18].... đừng viết là "ô 1", "ô 2"
Thân
 
concogia đã viết:
Tô tiếp vào vùng kết kết khoảng 10 hàng nữa xem sao vì đây là một dạng : "nhìn kết quả, đoán đề bài"
Những cell trong bảng tính có địa chỉ (hàng, cột) rõ ràng, bạn nên dùng nó, thí dụ [B16], [C18].... đừng viết là "ô 1", "ô 2"
Thân
Nhấp chuột vào đây để mở rộng...
Mình gửi lại hình chụp tô khoảng 10 ô nhé, đại ý là có tất cả 7 màu khác nhau. giờ điền tất cả khả năng tô 7 màu khác nhau vào 5 vị trí .
To Mau.jpg
 
Đọc từ trên xuống (từ #1 đến #9) mà chẳng hiểu gì cả. !$@!!!$@!!!$@!!!$@!!!$@!!
 
kute2007 đã viết:
E có một bài toán thế này , mong ace diễn đàn giúp e ạ.
----
E có một bảng gồm 7 màu khác nhau ( Bao gồm Yellow,light blue, gray, green, pink, ivory, red)
bài toán đặt ra là điền 7 màu trên vào 5 ô ( B15-F15) như file đính kèm
---
Thuật toán để điền màu vào 5 ô như sau:

B1: điền màu vàng ở ô số 1, và điền tất cả các khả năng xảy ra với 6 màu còn lại vào 4 ô còn lại.
B2: điền đồng thời màu vàng vào ô số 1 và 2, sau đó điền tất cả các khả năng xay ra với 6 màu còn lại với 3 ô còn lại
B3: điền đồng thời màu vàng vào ô số 1, 2 và 3, sau đó điền tất cả khả năng xảy ra với 6 màu còn lại ở 2 ô còn lại
B4: điền đồng thời màu vàng vào ô 1, 2, 3 và 4, sau đó điền tất cả các khả năng xảy ra với 6 màu còn lại ở 1 ô còn lại
B5: điền màu vàng ở tất cả 5 ô khi làm xong 4 bước trên.
B6: lập lại các bước 1,2,3,4,5 ở trên với các màu còn lại theo thứ tự. (light blue, gray, green, pink, ivory, red)

---
View attachment 155954
Mong ace giúp đỡ,
Nhấp chuột vào đây để mở rộng...

cứ theo đề bài mà làm

Mã: 
Dim arrResult, lCount As Long


Public Sub hello()
Dim r As Byte, colors, ub As Byte, c As Byte, arr, k As Long
colors = Array(65535, 16776960, 13553360, 5287936, 6684927, 10092543, 255, 11892015)
ub = UBound(colors)
ReDim arr(0 To ub - 1)
ReDim arrResult(1 To 1000000, 1 To 5)
lCount = 0


For r = 0 To ub Step 1
    k = 0
    For c = 0 To ub Step 1
        If c <> r Then
            arr(k) = c
            k = k + 1
        End If
    Next
    fillHello 1, 4, ub - 1, ";", arr, r
    fillHello 1, 3, ub - 1, ";", arr, r
    fillHello 1, 2, ub - 1, ";", arr, r
    fillHello 1, 1, ub - 1, ";", arr, r
    lCount = lCount + 1
    For c = 1 To UBound(arrResult, 2) Step 1
        arrResult(lCount, c) = r
    Next
Next
Application.ScreenUpdating = False
With Sheet1
    .Range("B16:F" & (.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 20)).Interior.ColorIndex = -4142
    For k = 1 To lCount Step 1
        For c = 1 To UBound(arrResult, 2) Step 1
            .Range("A" & k + 15).Offset(, c).Interior.color = colors(arrResult(k, c))
        Next
    Next
End With
Application.ScreenUpdating = True
End Sub


Private Sub fillHello(i As Byte, limI As Byte, maxNum As Byte, tmp As String, arr, missingItem As Byte)
Dim r As Byte, lStart As Long, lPos As Long, bCol As Byte
If i <= limI Then
    For r = 0 To maxNum Step 1
        If InStr(1, tmp, ";" & r & ";") = 0 Then
            fillHello i + 1, limI, maxNum, tmp & r & ";", arr, missingItem
        End If
    Next
Else
    lCount = lCount + 1
    tmp = Mid(tmp, 2)
    lStart = 1
    lPos = InStr(1, tmp, ";")
    For r = 1 To UBound(arrResult, 2) - limI Step 1
        bCol = bCol + 1
        arrResult(lCount, bCol) = missingItem
    Next
    
    Do While lPos > 0
        bCol = bCol + 1
        arrResult(lCount, bCol) = arr(Mid(tmp, lStart, lPos - lStart))
        lStart = lPos + 1
        lPos = InStr(lStart, tmp, ";")
    Loop
End If
End Sub
 
AutoReply đã viết:
cứ theo đề bài mà làm

Mã: 
Dim arrResult, lCount As Long


Public Sub hello()
Dim r As Byte, colors, ub As Byte, c As Byte, arr, k As Long
colors = Array(65535, 16776960, 13553360, 5287936, 6684927, 10092543, 255, 11892015)
ub = UBound(colors)
ReDim arr(0 To ub - 1)
ReDim arrResult(1 To 1000000, 1 To 5)
lCount = 0


For r = 0 To ub Step 1
    k = 0
    For c = 0 To ub Step 1
        If c <> r Then
            arr(k) = c
            k = k + 1
        End If
    Next
    fillHello 1, 4, ub - 1, ";", arr, r
    fillHello 1, 3, ub - 1, ";", arr, r
    fillHello 1, 2, ub - 1, ";", arr, r
    fillHello 1, 1, ub - 1, ";", arr, r
    lCount = lCount + 1
    For c = 1 To UBound(arrResult, 2) Step 1
        arrResult(lCount, c) = r
    Next
Next
Application.ScreenUpdating = False
With Sheet1
    .Range("B16:F" & (.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 20)).Interior.ColorIndex = -4142
    For k = 1 To lCount Step 1
        For c = 1 To UBound(arrResult, 2) Step 1
            .Range("A" & k + 15).Offset(, c).Interior.color = colors(arrResult(k, c))
        Next
    Next
End With
Application.ScreenUpdating = True
End Sub


Private Sub fillHello(i As Byte, limI As Byte, maxNum As Byte, tmp As String, arr, missingItem As Byte)
Dim r As Byte, lStart As Long, lPos As Long, bCol As Byte
If i <= limI Then
    For r = 0 To maxNum Step 1
        If InStr(1, tmp, ";" & r & ";") = 0 Then
            fillHello i + 1, limI, maxNum, tmp & r & ";", arr, missingItem
        End If
    Next
Else
    lCount = lCount + 1
    tmp = Mid(tmp, 2)
    lStart = 1
    lPos = InStr(1, tmp, ";")
    For r = 1 To UBound(arrResult, 2) - limI Step 1
        bCol = bCol + 1
        arrResult(lCount, bCol) = missingItem
    Next
    
    Do While lPos > 0
        bCol = bCol + 1
        arrResult(lCount, bCol) = arr(Mid(tmp, lStart, lPos - lStart))
        lStart = lPos + 1
        lPos = InStr(lStart, tmp, ";")
    Loop
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn bác nhưng bác ơi, bác có thể hướng dẫn cách chạy code trên được k ạ? e là người ngoại đạo chứ k giỏi excel vs lập trình ạ
.Cảm ơn bác nhiều ạ
 
Lần chỉnh sửa cuối:
Đọc giải thích
B1: điền màu vàng ở ô số 1, và điền tất cả các khả năng xảy ra với 6 màu còn lại vào 4 ô còn lại.
B2: điền đồng thời màu vàng vào ô số 1 và 2, sau đó điền tất cả các khả năng xay ra với 6 màu còn lại với 3 ô còn lại
B3: điền đồng thời màu vàng vào ô số 1, 2 và 3, sau đó điền tất cả khả năng xảy ra với 6 màu còn lại ở 2 ô còn lại
B4: điền đồng thời màu vàng vào ô 1, 2, 3 và 4, sau đó điền tất cả các khả năng xảy ra với 6 màu còn lại ở 1 ô còn lại
B5: điền màu vàng ở tất cả 5 ô khi làm xong 4 bước trên.
B6: lập lại các bước 1,2,3,4,5 ở trên với các màu còn lại theo thứ tự. (light blue, gray, green, pink, ivory, red)
Nhấp chuột vào đây để mở rộng...
Thì có lẽ kết quả như trong file này, Bấm nút GPE đến khi nào "vừa bụng" thì thôi.
Viết lòng vòng theo giải thích nên code cũng lòng vòng luôn.
Còn hình minh họa thì ... chẳng có quy luật nào.
 

File đính kèm

Lần chỉnh sửa cuối:
Ba Tê đã viết:
Đọc giải thích

Thì có lẽ kết quả như trong file này, Bấm nút GPE đến khi nào "vừa bụng" thì thôi.
Viết lòng vòng theo giải thích nên code cũng lòng vòng luôn.
Còn hình minh họa thì ... chẳng có quy luật nào.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhé, Nhưng bạn ơi, Theo đề bài thì không có màu D7, bạn có thể xóa bỏ màu D7 đi , mình tính ra là có tất cả 462 khả năng tổ hợp. Bạn làm lại giùm mình nhé, Cảm ơn rất nhiều
 
kute2007 đã viết:
Cảm ơn bạn nhé, Nhưng bạn ơi, Theo đề bài thì không có màu D7, bạn có thể xóa bỏ màu D7 đi , mình tính ra là có tất cả 462 khả năng tổ hợp. Bạn làm lại giùm mình nhé, Cảm ơn rất nhiều
Nhấp chuột vào đây để mở rộng...

Nếu không có D7 thì chỉnh code lại.
Thay Sub cũ trong Module thành Sub này.
Còn chuyện có bao nhiêu "khả năng" thì tôi không biết.
Bên trên bạn đâu có yêu cầu tính ra bao nhiêu "khả năng".
PHP: 
Public Sub GPE()
Dim Dic As Object, sArr(), dArr(1 To 1000, 1 To 5), Tem As String, Cll As Range
Dim I As Long, J As Long, K As Long, N As Long, X As Long, Mau As Long
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cll In Range("B3:B9")
    Dic.Add Cll.Value, Cll.Interior.ColorIndex
Next Cll
sArr = Range("B3:B9").Value
For I = 1 To 7
    For J = 1 To 5
        K = K + 1: Tem = "#" & I
        For N = 1 To J
            dArr(K, N) = sArr(I, 1)
        Next N
            For X = J + 1 To 5
                Randomize
                Do
                    Mau = Int((7 * Rnd) + 1)
                    If Mau <> I Then
                        If InStr(Tem, "#" & Mau) = 0 Then
                        dArr(K, X) = sArr(Mau, 1)
                        Exit Do
                        
                        End If
                    End If
                Loop
                Tem = Tem & "#" & Mau
            Next X
    Next J
Next I
[B16:F1000].ClearContents
[B16].Resize(K, 5) = dArr
For Each Cll In Range("B16").Resize(K, 5)
    Cll.Interior.ColorIndex = Dic.Item(Cll.Value)
Next Cll
'[B16].Resize(k, 5).ClearContents'
End Sub
 
Ba Tê đã viết:
Nếu không có D7 thì chỉnh code lại.
Thay Sub cũ trong Module thành Sub này.
Còn chuyện có bao nhiêu "khả năng" thì tôi không biết.
Bên trên bạn đâu có yêu cầu tính ra bao nhiêu "khả năng".
PHP: 
Public Sub GPE()
Dim Dic As Object, sArr(), dArr(1 To 1000, 1 To 5), Tem As String, Cll As Range
Dim I As Long, J As Long, K As Long, N As Long, X As Long, Mau As Long
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cll In Range("B3:B9")
    Dic.Add Cll.Value, Cll.Interior.ColorIndex
Next Cll
sArr = Range("B3:B9").Value
For I = 1 To 7
    For J = 1 To 5
        K = K + 1: Tem = "#" & I
        For N = 1 To J
            dArr(K, N) = sArr(I, 1)
        Next N
            For X = J + 1 To 5
                Randomize
                Do
                    Mau = Int((7 * Rnd) + 1)
                    If Mau <> I Then
                        If InStr(Tem, "#" & Mau) = 0 Then
                        dArr(K, X) = sArr(Mau, 1)
                        Exit Do
                        
                        End If
                    End If
                Loop
                Tem = Tem & "#" & Mau
            Next X
    Next J
Next I
[B16:F1000].ClearContents
[B16].Resize(K, 5) = dArr
For Each Cll In Range("B16").Resize(K, 5)
    Cll.Interior.ColorIndex = Dic.Item(Cll.Value)
Next Cll
'[B16].Resize(k, 5).ClearContents'
End Sub
Nhấp chuột vào đây để mở rộng...

Đề bài có mà bạn. Mình có nói là tất cả các khả năng xảy ra à. Thuật toán code mình có nói theo từng bước rồi bạn à. Bạn làm giúp minh hoàn chỉnh nha. Tks bạn
 
kute2007 đã viết:
Cảm ơn bạn nhé, Nhưng bạn ơi, Theo đề bài thì không có màu D7, bạn có thể xóa bỏ màu D7 đi , mình tính ra là có tất cả 462 khả năng tổ hợp. Bạn làm lại giùm mình nhé, Cảm ơn rất nhiều
Nhấp chuột vào đây để mở rộng...

nói tới nói lui mười mấy hiệp mới chịu lòi ra chữ tổ hợp à ? hay bạn nghĩ rằng người khác phải tự đoán ra chữ này để giúp bạn chăng ?
mặc dù liệt kê tổ hợp code cũng không có gì phức tạp , nhưng kiểu trình bày của bạn làm cho người khác mất kiên nhẫn , và chỉ tổ thiệt thòi cho bạn thôi .
 
kute2007 đã viết:
Cảm ơn bạn nhé, Nhưng bạn ơi, Theo đề bài thì không có màu D7, bạn có thể xóa bỏ màu D7 đi , mình tính ra là có tất cả 462 khả năng tổ hợp. Bạn làm lại giùm mình nhé, Cảm ơn rất nhiều
Nhấp chuột vào đây để mở rộng...

hình vẽ ở bài #1 vẫn có màu D7 , chúng tôi còn nhìn thấy cơ mà , xuống đây lại nói là không có màu D7 ....
 

File đính kèm

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

C
Tải kết quả xổ số 3 miền về excel
    • Thích
2
Trả lời
101
Đọc
22K
Gà Con yêu VBA
Gà Con yêu VBA
HeSanbi
Dò vé số 3 miền, và thu thập kết quả sổ xố siêu nhanh với Excel
    • Thích
    • Yêu thích
Trả lời
22
Đọc
5K
Gà Con yêu VBA
Gà Con yêu VBA
SA_DQ
[2] Bình luận của Copilot về các ván cờ vua (1 người xem)
Trả lời
18
Đọc
472
SA_DQ
SA_DQ
H
Cách tính ngày kết thúc khóa học
Trả lời
2
Đọc
66
Gà Con yêu VBA
Gà Con yêu VBA
E
  • Question Question
Cách nào để sắp xếp lái xe vào list danh sách
Trả lời
3
Đọc
186
Gà Con yêu VBA
Gà Con yêu VBA
havanvinhqh
  • Đã giải quyết
Nâng cấp PM Excel để chạy mượt mà hơn
    • Ngạc nhiên
    • Cười
Trả lời
5
Đọc
341
Trần Văn Bình
T
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
68
Đọc
13K
HeSanbi
HeSanbi
ongke0711
Tạo thông báo nhắc nhở công việc (Excel + PowerShell + Task scheduler)
    • Thích
    • Yêu thích
Trả lời
16
Đọc
503
ongke0711
ongke0711
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
5 6 7
Trả lời
661
Đọc
104K
pycckuu410
pycckuu410
Trungvt3
Get data từ From file excel workbook, load to xong dữ liệu thì Định dạng bị thay đổi so với dữ liệu từ file excel
Trả lời
1
Đọc
96
ptm0412
ptm0412
phuongnam366377
Xây dựng RPC Server cho Excel / Access bằng Delphi – Tận dụng lại DLL và bảo mật mã nguồn
    • Thích
Trả lời
19
Đọc
1K
phuongnam366377
phuongnam366377
Nguyễn Duy Tuân
Hàm BS_TEXT trộn văn bản trong Excel với Add-in A-Tools v10
Trả lời
1
Đọc
511
Nguyễn Duy Tuân
Nguyễn Duy Tuân
G
  • Question Question
Xin hỏi về Lỗi Path Not Found (1 người xem)
Trả lời
11
Đọc
243
ongke0711
ongke0711
Maika8008
Liệt kê file trong 1 thư mục của Google Drive
Trả lời
0
Đọc
103
Maika8008
Maika8008
K
Tư vấn dùng máy tính chip AMD hay Intel
Trả lời
6
Đọc
343
vuvo_nhenhang
V
Maika8008
Dùng Apps Script gửi mail hàng loạt từ Google sheets
    • Thích
    • Yêu thích
Trả lời
6
Đọc
316
befaint
befaint
Tiger Nau
In dữ liệu trong word bị lỗi
Trả lời
0
Đọc
75
Tiger Nau
Tiger Nau
J
lỗi không lưu được dữ liệu trong file excel
Trả lời
3
Đọc
135
jenny 129
J
N
  • Question Question
Một lỗi rất khó chịu của VBA khi đọc chuỗi Unicode
    • Thích
Trả lời
3
Đọc
209
ongke0711
ongke0711
nvtnet
  • Question Question
Nhờ các bác giúp đỡ tạo chương trình sao chép dữ liệu vào thư mục con
Trả lời
0
Đọc
102
nvtnet
nvtnet
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