Tô màu theo điều kiện bằng VBA?

Liên hệ QC
M

Miền Cát Trắng

Thành viên hoạt động
Tham gia
18/5/13
Bài viết
171
Được thích
37
Xin kính chào mọi người.
Tôi đang gặp phải một vấn đề như đã nêu rõ trong file đính kèm.
Nếu sử dụng chức năng CF thì tôi có thể làm được nhưng tôi muốn tìm hiểu khi làm bằng vba. Mong mọi người giúp đỡ.
Xin cảm ơn!
 

File đính kèm

  • Tomau.xls
    24 KB · Đọc: 445
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Cám ơn cả nhà, Mình đã làm được
Mình tô màu theo vùng và chạy code mẫu, lấy code mẫu pass vô và điều chỉnh ô lại theo mong muốn
Range("A6:G14").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 13434879
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A15:G23").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 13434828
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveWindow.SmallScroll Down:=15
Range("A24:G50").Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16772300
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B21").Select
ActiveWindow.SmallScroll Down:=-21
Range("A6:G50").Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Range("F16").Select
ActiveWindow.SmallScroll Down:=-30
Range("F11").Select
ActiveWindow.SmallScroll Down:=-42
Range("F11").Select
 
Upvote 0
giangintem đã viết:
Cám ơn cả nhà, Mình đã làm được
Mình tô màu theo vùng và chạy code mẫu, lấy code mẫu pass vô và điều chỉnh ô lại theo mong muốn
Range("A6:G14").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 13434879
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A15:G23").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 13434828
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveWindow.SmallScroll Down:=15
Range("A24:G50").Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16772300
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("B21").Select
ActiveWindow.SmallScroll Down:=-21
Range("A6:G50").Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Range("F16").Select
ActiveWindow.SmallScroll Down:=-30
Range("F11").Select
ActiveWindow.SmallScroll Down:=-42
Range("F11").Select
Nhấp chuột vào đây để mở rộng...
À tức là cái chỗ dài thòng lòng đó nó gần gần như này đấy bạn:
Mã: 
Sub ToMauSieuTuDong()
    Range("A6:G14").Interior.ColorIndex = 36
    Range("A15:G23").Interior.ColorIndex = 20
    Range("A24:G50").Interior.ColorIndex = 37
    Range("A6:G50").Borders.LineStyle = xlContinuous
End Sub
 
Upvote 0
Cám ơn Bạn, mình không biết làm nên chỉ làm được như vậy thôi. Mình copy và sử dụng đoạn code của Bạn cũng được rồi
 
Upvote 0
Cho em hỏi cách tô màu với:
Nếu thu được tiền liên tục trong 10 ngày thì ngày thứ 7 bôi màu cam,
nếu 14 ngày liên tục thì ngày thứ 7 và ngày thứ 14 bôi màu cam,
Nếu 21 ngày liên tục thì ngày thứ 7, 14 và 21 bôi màu cam
Nếu 28 ngày liên tục thì ngày thứ 7, 14, 21, 28 bôi màu cam
nếu ngày nào không thu được tiền thì bôi màu vàng
còn lại các ngày màu trắng
Tính tổng số tiền các ngày màu cam của từng người
cám ơn các anh chị
 

File đính kèm

  • Bôi màu.xlsx
    10.7 KB · Đọc: 26
Upvote 0
tranthemai đã viết:
Cho em hỏi cách tô màu với:
Nếu thu được tiền liên tục trong 10 ngày thì ngày thứ 7 bôi màu cam,
nếu 14 ngày liên tục thì ngày thứ 7 và ngày thứ 14 bôi màu cam,
Nếu 21 ngày liên tục thì ngày thứ 7, 14 và 21 bôi màu cam
Nếu 28 ngày liên tục thì ngày thứ 7, 14, 21, 28 bôi màu cam
nếu ngày nào không thu được tiền thì bôi màu vàng
còn lại các ngày màu trắng
Tính tổng số tiền các ngày màu cam của từng người
cám ơn các anh chị
Nhấp chuột vào đây để mở rộng...
Thử code dưới đây
Mã: 
Option Explicit

Sub A_mau_tien()
Dim DL, tien
Dim i, j, k, t
With Sheet1
    DL = .Range("A2", .Range("AF" & Rows.Count).End(xlUp))
    .Range("A2", .Range("AF" & Rows.Count).End(xlUp)).ClearFormats
    .Range("A2", .Range("AF" & Rows.Count).End(xlUp)).Borders.LineStyle = 1
    For i = 1 To UBound(DL)
        k = 0
        tien = 0
        For j = 2 To 32
            If DL(i, j) > 0 Then
                k = k + 1
                If k = 10 Then
                    t = j - 4
                Else
                    If k > 10 And k Mod 7 = 0 Then t = j - 1
                End If
                If t Then
                    'tien = tien + DL(i, j)
                    tien = tien + DL(i, t + 1)'<--sua lai
                    .Range("A" & i + 1).Offset(, t).Select
                    Macro1
                    t = 0
                End If
            Else
                .Range("A" & i + 1).Offset(, j - 1).Select
                Macro2
                k = 0
            End If
        Next j
        .Range("AG" & i + 1) = tien
    Next i
End With
End Sub

Sub Macro1()
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub
Sub Macro2()
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Bác ChaoQuay sửa hộ em cái này với, khi đưa code của bác vào dữ liệu thì em đã sửa lại những cái em biết thì thấy phần tô màu đúng rồi, còn phần tính tổng theo màu vẫn gặp khó khăn, em thấy nó tự lấy dữ liệu ở ô số 10 đem cộng với những ô màu cam khác chứ không phải ở ô thứ 7 có màu cam
 

File đính kèm

  • LUONG SL TS 11 2019.xlsm
    100.1 KB · Đọc: 16
Upvote 0
tranthemai đã viết:
Bác ChaoQuay sửa hộ em cái này với, khi đưa code của bác vào dữ liệu thì em đã sửa lại những cái em biết thì thấy phần tô màu đúng rồi, còn phần tính tổng theo màu vẫn gặp khó khăn, em thấy nó tự lấy dữ liệu ở ô số 10 đem cộng với những ô màu cam khác chứ không phải ở ô thứ 7 có màu cam
Nhấp chuột vào đây để mở rộng...
Đoạn code trên cộng tiền bị lỗi, sorry.
Bạn xem lại bên dưới, thay dòng trên = dòng dưới là được
Mã: 
If t Then
    'tien = tien + DL(i, j)
                    
    tien = tien + DL(i, t + 1)
 
Upvote 0
CHAOQUAY đã viết:
Đoạn code trên cộng tiền bị lỗi, sorry.
Bạn xem lại bên dưới, thay dòng trên = dòng dưới là được
Mã: 
If t Then
    'tien = tien + DL(i, j)
                  
    tien = tien + DL(i, t + 1)
Nhấp chuột vào đây để mở rộng...
CHAOQUAY đã viết:
Đoạn code trên cộng tiền bị lỗi, sorry.
Bạn xem lại bên dưới, thay dòng trên = dòng dưới là được
Mã: 
If t Then
    'tien = tien + DL(i, j)
                   
    tien = tien + DL(i, t + 1)
Nhấp chuột vào đây để mở rộng...
Thanks Bac chuẩn rồi bác. Cám ơn bác đã giúp đỡ em nhiệt tình
 
Upvote 0
Nhờ các anh chị giúp tô màu các ô theo điều kiện ( Yêu cầu nêu rõ trong file ).
Cảm ơn rất nhiều.
 

File đính kèm

  • Book1.xls
    38.5 KB · Đọc: 11
Upvote 0
giaiphap đã viết:
Cái này dùng thử CF kết quả cũng được.
Nhấp chuột vào đây để mở rộng...
Hôm trước mình cũng làm thế nhưng sau khi CF xong nó xóa mất tiêu các định dạng của mình ( Có lẽ do lỗi của file ). Cảm ơn bạn đã hỗ trợ.
Bài đã được tự động gộp:

huongmuine đã viết:
Hôm trước mình cũng làm thế nhưng sau khi CF xong nó xóa mất tiêu các định dạng của mình ( Có lẽ do lỗi của file. File sử dụng vba để Highlight ). Cảm ơn bạn đã hỗ trợ.
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
Xin phép diễn đàn
em cũng có nội dung tương tự nhờ thầy và các anh chị em hỗ trợ thay thế bằng VBA
Hiện tại file đính kèm đang sử dụng định dạng có điều kiện
tuy nhiên số lượng ít dòng thì dùng OK nhưng khi lên đến 800 dòng file chậm quá
Điều kiện em cũng đã ghi trong file

em trân thành cảm ơn anh chị
 

File đính kèm

  • Xác nhận tiến độ.xlsx
    867.7 KB · Đọc: 14
Upvote 0
Ba Tê đã viết:
Public Sub GPE() Dim Rng As Range, Cll As Range, DK As Long With Sheet1 DK = .[C5].Value .[C8:K1000].Interior.ColorIndex = 0 Set Rng = .Range(.[C8], .[C8].End(xlDown)) For Each Cll In Rng If Cll.Value = DK Then Cll.Resize(, 9).Interior.ColorIndex = 6 MsgBox "Ma oi, Ma oi ..... Cuu con!" End If Next Cll End With
Nhấp chuột vào đây để mở rộng...
Ba Tê đã viết:
Xem Cái "má ơi...má ơi ..." này thử xem, sao nhiều cái "oái oăm" vậy?
PHP: 
Public Sub GPE()
Dim Rng As Range, Cll As Range, DK As Long, MaOI As Range
With Sheet1
    DK = .[C5].Value
    Set MaOI = Union(.[C8:E17], .[G8:I17], .[K8:K17])
    MaOI.Interior.ColorIndex = 0
    Set Rng = .Range(.[C8], .[C8].End(xlDown))
    For Each Cll In Rng
        If Cll.Value = DK Then
            Set MaOI = Union(Cll.Resize(, 3), Cll.Offset(, 4).Resize(, 3), Cll.Offset(, 8))
            MaOI.Interior.ColorIndex = 6
            MsgBox "Ma oi, Ma oi ..... Cuu con!"
        End If
    Next Cll
End With
Set Rng = Nothing
Set MaOI = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
nếu thay C5 bằng 1 vùng dữ liệu từ c5 tới c 200 thì sao ạ?
 
Upvote 0
Luong24 đã viết:
Nghĩa là như này
DK = .[C5].Value
Giờ e muốn thay C5 bằng 1 vùng dữ liệu chứ không phải 1 ô ( từ ô C5 đến ô C200 ) thì viết như nào ạ?
Nhấp chuột vào đây để mở rộng...
File của chủ bài đăng có 1 ô điều kiện & 1 vùng cần xem xét để tô màu;
Cái chính là vùng xem xét tô màu đang là [C8:K17]
Như bạn nêu là ô điều kiện biến thành vùng điều kiện & đã ghi rõ là [C5:C200]
Vậy là vùng điều kiện đã chồng lấn lên vùng cần khảo sát để tô màu
Chuyện này dễ diễn ra chiến tranh nếu 2 vùng đó là lãnh thổ của 2 nước láng giềng thù địch nhau!
Trước tiên là bạn phải tách phần chồng lấn của 2 vùng này ra rạch ròi cái đã!
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
Cần giúp sao chép C1 từ B1
Trả lời
3
Đọc
68
tle2003
T
A
Tìm số nhỏ nhất, số lớn nhất theo ngày
Trả lời
6
Đọc
67
hoangtuaotrang_hp_vn
H
H
  • Question
Code VBA cho kết quả dòng, cột theo điều kiện từ 2 Sheets
Trả lời
1
Đọc
51
VetMini
V
test1986
  • Question
HELP! Sử dụng combobox để cập nhật dữ liệu trong file Excel
Trả lời
16
Đọc
487
BuiQuangThuan
B
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
1
Đọc
47
BuiQuangThuan
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom