Nhập ký tự "X" cho ô từ C3:C2000 nếu ô B3:B2000, có hàng nào chữ màu đỏ tươi

[LuuGiaPhúc]

Nhờ các anh chị viết dùm em code kiểm tra xem ô nào bên cột B có chữ màu đỏ tươi thì điền ký tự X vào ô bên cột C tương ứng
À, giữa các câu hỏi, có khi "người ta" vui vui thì họ xuống dòng, thích thì xuống 1 dòng, buồn xuống 2 dòng, lung tung cả.
Do file đề thi gốc nó là file word, em copy và paste vào ô A2:B600 của template này nên khi viết code, các anh chị xem thử nó có bị dính lỗi ở vụ xuống dòng này hay không nhé.
Em cảm ơn ạ

 

[SA_DQ]

Sub DanhDauTheoMauFont()
 Dim Rws As Long, Cls As Range, Rng As Range
 
 With Sheet1
    Rws = .[B3].CurrentRegion.Rows.Count
    For Each Cls In .Range(.[B3], .[B3].End(xlDown))
        If Cls.Font.ColorIndex > 2 Then Cls.Offset(, 1).Value = "GPE.COM"
    Next Cls
 End With
End Sub

 

[LuuGiaPhúc]

Sub DanhDauTheoMauFont()
 Dim Rws As Long, Cls As Range, Rng As Range
 
 With Sheet1
    Rws = .[B3].CurrentRegion.Rows.Count
    For Each Cls In .Range(.[B3], .[B3].End(xlDown))
        If Cls.Font.ColorIndex > 2 Then Cls.Offset(, 1).Value = "GPE.COM"
    Next Cls
 End With
End Sub

Em cảm ơn anh ạ. Code đã chạy rồi, có điều em phát hiện ra 1 việc :
Cột B không phải em nhập tay, mà là em nhận 1 file Word từ người khác, em copy nó vào cột A:B để làm câu trả lời và câu hỏi), tuy nhiên thỉnh thoàng do trong file word người ta xuống dòng rất ngẫu nhiên (chắc do nhập liệu bằng tay, có khi họ xuống 1 dòng giữa 2 câu, có khi buồn buồn họ xuống hẳn 2 dòng luôn. File word này trung bình có khoảng 100 câu hỏi , mỗi câu hỏi có từ 4 đến 5 câu trả lời ==> khoảng hơn 500 dòng) nên cái câu lệnh For Each Cls In .Range(.[B3], .[B3].End(xlDown)) thì nó chỉ chạy được cho đúng câu đầu tiên thôi.
Khi em thay bằng For Each Cls In .Range("B3:B600") thì nó chạy được, nhưng chạy khá lâu (khoảng gần 1 phút).
không biết có phải em làm sai không ạ hoặc do file tổng của em hiện nay quá nặng (khoảng 30Mb) nên khi chạy code này thì nó lâu , mong anh góp ý cho e.

 

[SA_DQ]

Thì bạn sửa lại câu lệnh bắt đầu vòng lặp thành

For Each Cls In .Range(.[B3], .[B3].Resize(Rws))

thử xem sao

Còn nếu vẫn sai như cũ thì For Each Cls In .Range(.[B3], .[B98765].End(xlUp))

 

[Nhattanktnn]

Thì bạn sửa lại câu lệnh bắt đầu vòng lặp thành

For Each Cls In .Range(.[B3], .[B3].Resize(Rws))

thử xem sao

currentregion mà có một dòng trống ở giữa thì nó không lấy phần dưới đâu bác Sa ơi

 

[SA_DQ]

Thì tại file #1 sao mần vậy mà!

 

[Nhattanktnn]

Thì tại file #1 sao mần vậy mà!

Nhưng bài #4 lại trả lời cho bài #3, mà bài 3 họ lại có khúc này, mùa covid ai cũng buồn nên chắc xuống dòng cũng hơi nhiều bác ạ

có khi họ xuống 1 dòng giữa 2 câu, có khi buồn buồn họ xuống hẳn 2 dòng luôn

 

[LuuGiaPhúc]

Thì tại file #1 sao mần vậy mà!

Dạ, tại em không lường trước tình huống này, bác ạ, nó tùy file, có file thì "ngoan và ngon", có file nó lại "chứng" thế, em tải code về chạy file đầu êm, lấy thử file khác up vào mới phát hiện ra vụ xuống dòng ngẫu nhiên thế này. Em đã sửa lại nội dung và file đính kèm mới ở bài #1 rồi ạ

 

[Nhattanktnn]

Dạ, tại em không lường trước tình huống này, bác ạ, nó tùy file, có file thì "ngoan và ngon", có file nó lại "chứng" thế, em tải code về chạy file đầu êm, lấy thử file khác up vào mới phát hiện ra vụ xuống dòng ngẫu nhiên thế này. Em đã sửa lại nội dung và file đính kèm mới ở bài #1 rồi ạ

Thử nhé :

Option Explicit

Sub DanhDauTheoMauFont()
 Dim Rws As Long, Cls As Range, Rng As Range, dRng As Range
 With Sheet1
    Rws = .Cells(Rows.Count, "B").End(xlUp).Row
    For Each Cls In .Range("B3:B" & Rws)
        If Cls.Font.ColorIndex > 2 Then
            If dRng Is Nothing Then
                Set dRng = Cls.Offset(, 1)
            Else
                Set dRng = Union(dRng, Cls.Offset(, 1))
            End If
        End If
    Next Cls
    dRng.Value = "X"
    dRng.Font.Color = vbRed
 End With
End Sub

 

[LuuGiaPhúc]

Dạ, tại em không lường trước tình huống này, bác ạ, nó tùy file, có file thì "ngoan và ngon", có file nó lại "chứng" thế, em tải code về chạy file đầu êm, lấy thử file khác up vào mới phát hiện ra vụ xuống dòng ngẫu nhiên thế này. Em đã sửa lại nội dung và file đính kèm mới ở bài #1 rồi ạ

Thử nhé :

Option Explicit

Sub DanhDauTheoMauFont()
 Dim Rws As Long, Cls As Range, Rng As Range, dRng As Range
 With Sheet1
    Rws = .Cells(Rows.Count, "B").End(xlUp).Row
    For Each Cls In .Range("B3:C" & Rws)
        If Cls.Font.ColorIndex > 2 Then
            If dRng Is Nothing Then
                Set dRng = Cls.Offset(, 1)
            Else
                Set dRng = Union(dRng, Cls.Offset(, 1))
            End If
        End If
    Next Cls
    dRng.Value = "X"
    dRng.Font.Color = vbRed
 End With
End Sub

code của bạn chạy rất nhanh, chỉ khoảng 3 giây là xong, có điều nó đánh dấu "X" ở 2 cột luôn.

 

[hoangtuaotrang_hp_vn]

code của bạn chạy rất nhanh, chỉ khoảng 3 giây là xong, có điều nó đánh dấu "X" ở 2 cột luôn.

View attachment 263489

Nếu tô đỏ rồi mà đổi ý, không tô đỏ nữa thì dấu X vẫn còn ở đó (tuyệt vời hơn nếu: mình tô đen trở lại hoặc tô màu khác thì dấu X mất đi, sẽ kỳ diệu hơn)

 

[Nhattanktnn]

code của bạn chạy rất nhanh, chỉ khoảng 3 giây là xong, có điều nó đánh dấu "X" ở 2 cột luôn.

View attachment 263489

À làm nhanh ẩu quá gõ nhầm code cho chạy cả cột B và C. Sửa lại rồi đó bạn

 

[LuuGiaPhúc]

À làm nhanh ẩu quá gõ nhầm code cho chạy cả cột B và C. Sửa lại rồi đó bạn

Tuyệt vời. cảm ơn bạn nhiều lắm. code chạy rất nhanh