Chạy code tô màu cho dữ liệu trùng vượt quá 10 dữ liệu (1 người xem)

AnhThu-1976 · 20/1/18

Các anh/chị và các bạn giúp trường hợp mà em đã mô tả trong File
Vì số lượng là rất nhiều, nên em muốn dùng code chứ không dùng CF để tránh nặng File
Em cảm ơn

Hoang2013 · 20/1/18

Đây là macro tô màu nền những ô thỏa:

PHP:

Sub ToMauHon10DongLienTuc1Fieu()
 Dim Rng As Range, Cls As Range, mRg As Range
 Dim MyColor As Byte, Dm As Byte
 Dim SoFieu As String

 Sheets("TH").Select:                   Randomize
 MyColor = 34 + 9 * Rnd() \ 1
 Set Rng = Range([a9], [A65500].End(xlUp))
 Rng.Interior.ColorIndex = 0
 For Each Cls In Rng
    If Cls.Value = "" Then
        If Dm > 10 Then
            MyColor = MyColor + 1
            If MyColor > 42 Then MyColor = 34
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Nothing
        Dm = 0:                         SoFieu = ""
    ElseIf Cls.Value <> SoFieu Then
        If Dm > 10 Then
            MyColor = MyColor + 1
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Cls:                  SoFieu = Cls.Value
        Dm = 1
    ElseIf Cls.Value = SoFieu Then
        Dm = 1 + Dm:
        Set mRg = Union(mRg, Cls)
    End If
 Next Cls
 If Dm > 10 Then
    mRg.Interior.ColorIndex = MyColor + 1
    Set mRg = Nothing
 End If
End Sub

ndu96081631 · 20/1/18

AnhThu-1976 đã viết:
Các anh/chị và các bạn giúp trường hợp mà em đã mô tả trong File
Vì số lượng là rất nhiều, nên em muốn dùng code chứ không dùng CF để tránh nặng File
Em cảm ơn

Tôi nghĩ code đơn giản thế này:

Mã:

Sub Test()
  Dim rngArea As Range, bCheck As Boolean
  For Each rngArea In Range("A9:A60000").SpecialCells(xlCellTypeConstants).Areas
    If rngArea.Count > 10 Then
      rngArea.Font.Color = vbRed
      bCheck = True
    Else
      rngArea.Font.Color = 0
    End If
  Next
  If bCheck Then MsgBox "Có phieu vuot quá 10"
End Sub

AnhThu-1976 · 20/1/18

Hoang2013 đã viết:
Đây là macro tô màu nền những ô thỏa:

Cảm ơn bạn, nhưng code của bạn có thể thêm câu
MsgBox "Có phieu vuot quá 10" được không, vì mục đích nếu có trông báo thì mình mới tìm nó còn không thì thôi

AnhThu-1976 · 20/1/18

ndu96081631 đã viết:

Tôi nghĩ code đơn giản thế này:

Mã:

Sub Test()
  Dim rngArea As Range, bCheck As Boolean
  For Each rngArea In Range("A9:A60000").SpecialCells(xlCellTypeConstants).Areas
    If rngArea.Count > 10 Then
      rngArea.Font.Color = vbRed
      bCheck = True
    Else
      rngArea.Font.Color = 0
    End If
  Next
  If bCheck Then MsgBox "Có phieu vuot quá 10"
End Sub

Em cảm ơn, có lẽ em diễn đạt chưa hết ý nên thầy còn còn hiểu sai ý của em
Code còn chạy chưa đúng, ví dụ: từ ô A10 đến A15 là N001 (có 6 ô), từ ô A16 đến A20 là N002 (có 5 ô) khi chạy code thì nó cũng báo trùng và tô màu, thực tế là không trùng từ 10 ô trở lên

Hoang2013 · 20/1/18

Nhưng code của bạn có thể thêm câu
MsgBox "Có phieu vuot quá 10" được không, vì mục đích nếu có trông báo thì mình mới tìm nó còn không thì thôi

Là vầy:

PHP:

Const TB As String = "Có Fiéu Quá 10 Dòng!"    'Thêm dòng này tại dòng khai báo các tham biến'
 Dim SoFieu As String, SMS As String      'Bổ sung Thêm 1 Tham Biến'

Dưới ngay các dòng lệnh:

Mã:

If Dm > 10 Then

Ta thêm ngay câu lệnh

PHP:

  SMS = TB

& thêm vô trước dòng 'End Sub' câu lệnh:

PHP:

 If SMS = TB Then MsgBox SMS

Bạn cố gắng thử trước xem sao!

ndu96081631 · 20/1/18

AnhThu-1976 đã viết:
Em cảm ơn, có lẽ em diễn đạt chưa hết ý nên thầy còn còn hiểu sai ý của em
Code còn chạy chưa đúng, ví dụ: từ ô A10 đến A15 là N001 (có 6 ô), từ ô A16 đến A20 là N002 (có 5 ô) khi chạy code thì nó cũng báo trùng và tô màu, thực tế là không trùng từ 10 ô trở lên

Lỗi tại bạn đưa dữ liệu không tổng quát thôi
Code chỉ làm công việc: "Chạy đúng như những gì đã mô tả"

SA_DQ · 20/1/18

Tôi nghĩ code đơn giản thế này:

Còn đề fòng trường hợp có 13 fiếu liên tục & nối tiếp ngay sau đó hơn chục fiếu khác nữa;
Khi đó nên tô màu khác nhau để dễ bề hành xử!

PHP:

  '
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01
GPE 01'
XN002'
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02
GPE02'

AnhThu-1976 · 20/1/18

Hoang2013 đã viết:
Là vầy:

PHP:

Const TB As String = "Có Fiéu Quá 10 Dòng!" 'Thêm dòng này tại dòng khai báo các tham biến' Dim SoFieu As String, SMS As String 'Bổ sung Thêm 1 Tham Biến'

Dưới ngay các dòng lệnh:

Mã:

If Dm > 10 Then

Ta thêm ngay câu lệnh

PHP:

SMS = TB

& thêm vô trước dòng 'End Sub' câu lệnh:

PHP:

If SMS = TB Then MsgBox SMS

Bạn cố gắng thử trước xem sao!

Đã sửa lại code theo như bạn hướng dẫn nhưng vẫn chưa thấy thông báo MsgBox, nhờ bạn xem lại

PHP:

Sub ToMauHon10DongLienTuc1Fieu()
 Dim Rng As Range, Cls As Range, mRg As Range
 Dim MyColor As Byte, Dm As Byte
 Const TB As String = "Có Fiéu Quá 10 Dòng!"    'Thêm dòng này t?i dòng khai báo các tham bi?n'
 Dim SoFieu As String, SMS As String
 Sheets("TH").Select:                   Randomize
 MyColor = 34 + 9 * Rnd() \ 1
 Set Rng = Range([a9], [A65500].End(xlUp))
 Rng.Interior.ColorIndex = 0
 For Each Cls In Rng
    If Cls.Value = "" Then
        If Dm > 10 Then
            MyColor = MyColor + 1
            If MyColor > 42 Then MyColor = 34
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Nothing
        Dm = 0:                         SoFieu = ""
    ElseIf Cls.Value <> SoFieu Then
        If Dm > 10 Then
            MyColor = MyColor + 1
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Cls:                  SoFieu = Cls.Value
        Dm = 1
    ElseIf Cls.Value = SoFieu Then
        Dm = 1 + Dm:
        Set mRg = Union(mRg, Cls)
    End If
 Next Cls
 If Dm > 10 Then
 SMS = TB
    mRg.Interior.ColorIndex = MyColor + 1
    Set mRg = Nothing
 End If
 If SMS = TB Then MsgBox SMS
End Sub

Hoang2013 · 20/1/18

Có 3 dòng cần thêm; nhưng bạn mới thêm 1 dòng ở cuối thôi;
Dò tiếp lên trên đi!

AnhThu-1976 · 20/1/18

Hoang2013 đã viết:
Có 3 dòng cần thêm; nhưng bạn mới thêm 1 dòng ở cuối thôi;
Dò tiếp lên trên đi!

Đã thêm đủ 3 dòng nhưng không thông báo MsgBox, cụ thể ở những dòng có ghi chú : 'Thêm
Bạn xem giúp

PHP:

Sub ToMauHon10DongLienTuc1Fieu()
 Dim Rng As Range, Cls As Range, mRg As Range
 Dim MyColor As Byte, Dm As Byte
 Const TB As String = "Có Fiéu Quá 10 Dòng!"    'Thêm dòng này t?i dòng khai báo các tham bi?n'
 Dim SoFieu As String, SMS As String ' Thêm 1 bien
 Sheets("TH").Select:                   Randomize
 MyColor = 34 + 9 * Rnd() \ 1
 Set Rng = Range([a9], [A65500].End(xlUp))
 Rng.Interior.ColorIndex = 0
 For Each Cls In Rng
    If Cls.Value = "" Then
        If Dm > 10 Then
            MyColor = MyColor + 1
            If MyColor > 42 Then MyColor = 34
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Nothing
        Dm = 0:                         SoFieu = ""
    ElseIf Cls.Value <> SoFieu Then
        If Dm > 10 Then
            MyColor = MyColor + 1
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Cls:                  SoFieu = Cls.Value
        Dm = 1
    ElseIf Cls.Value = SoFieu Then
        Dm = 1 + Dm:
        Set mRg = Union(mRg, Cls)
    End If
 Next Cls
 If Dm > 10 Then
 SMS = TB 'thêm
    mRg.Interior.ColorIndex = MyColor + 1
    Set mRg = Nothing
 End If
 If SMS = TB Then MsgBox SMS 'thêm
End Sub

Hoang2013 · 20/1/18

Mệt với bạn quá đi thôi!

PHP:

Sub ToMauHon10DongLienTuc1Fieu()
 Dim Rng As Range, Cls As Range, mRg As Range
 Dim MyColor As Byte, Dm As Byte
 Const TB As String = "Có Fiéu Quá 10 Dòng!"
 Dim SoFieu As String, SMS As String

 Sheets("TH").Select:                   Randomize
 MyColor = 34 + 9 * Rnd() \ 1
 Set Rng = Range([a9], [A65500].End(xlUp))
 Rng.Interior.ColorIndex = 0
 For Each Cls In Rng
    If Cls.Value = "" Then
        If Dm > 10 Then
            MyColor = MyColor + 1:      SMS = TB    '*'
            If MyColor > 42 Then MyColor = 34
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Nothing
        Dm = 0:                         SoFieu = ""
    ElseIf Cls.Value <> SoFieu Then
        If Dm > 10 Then
            MyColor = MyColor + 1:      SMS = TB    '*'
            mRg.Interior.ColorIndex = MyColor
        End If
        Set mRg = Cls:                  SoFieu = Cls.Value
        Dm = 1
    ElseIf Cls.Value = SoFieu Then
        Dm = 1 + Dm:
        Set mRg = Union(mRg, Cls)
    End If
 Next Cls
 If Dm > 10 Then
    mRg.Interior.ColorIndex = MyColor + 1
    Set mRg = Nothing:                  SMS = TB    '*'
 End If
 MsgBox SMS, , "GPE.COM Xin Chào!"
End Sub

NguyenNgocThuHien · 20/1/18

PHP:

Option Explicit
 Sub ToMauHon10DongLienTuc1Fieu()
 
    Dim rngSource As Range, rngCellStart As Range
    Dim vData, vDataLast
    Dim lngColor As Long
    Dim lngRowCurrent As Long, lngRowStart As Long, lngNumCondi As Long
    On Error Resume Next
    Set rngSource = Application.InputBox("Chon vung can  kiem tra:", Type:=8)
    If Err.Number <> 0 Then
        Err.Clear: Exit Sub
    End If
    On Error GoTo 0
                
    Set rngSource = rngSource.Columns(1)
    rngSource.Interior.ColorIndex = 0 'ko mau
    If rngSource.Cells.Count = 1 Then
        ReDim vData(1 To 1, 1 To 1) As Variant
        vData(1, 1) = rngSource.Value
    Else
        vData = rngSource.Value
    End If
    
    lngColor = 1
    lngRowStart = 1 'dong bat dau
    vDataLast = vData(1, 1) & "MeoMunDangYeu"
    Set rngCellStart = rngSource.Cells(1, 1)
    
    For lngRowCurrent = LBound(vData) To UBound(vData)
        If vData(lngRowCurrent, 1) <> vDataLast Then
            If lngRowCurrent - lngRowStart >= 10 Then
                lngNumCondi = lngNumCondi + 1
                rngCellStart.Item(lngRowStart).Resize(lngRowCurrent - lngRowStart).Interior.ColorIndex = lngColor
                lngColor = lngColor + 1
                If lngColor >= 57 Then lngColor = 1
                
            End If
            lngRowStart = lngRowCurrent
            vDataLast = vData(lngRowCurrent, 1)
        End If
    Next
    
    If (UBound(vData) - lngRowStart + 1) >= 10 Then
        lngNumCondi = lngNumCondi + 1
        rngCellStart.Item(lngRowStart).Resize(UBound(vData) - lngRowStart + 1).Interior.ColorIndex = lngColor
        'If lngColor >= 42 Then lngColor = 1
                
    End If
    MsgBox "So trung la: " & CStr(lngNumCondi)
    
 
End Sub

VetMini · 22/1/18

Kiểu highlight như thế này, ngừoi ta đặt một Sub riêng để làm, dễ chỉnh sửa hơn

Private Sub RgHiLight(byVal rg As Range, byVal hilite As Boolean)
If hilite Then
' set ...
Else
' reset ...
End If
End Sub

Nếu muốn đổi đủ màu thì lập thêm 1 biến static

Private Sub RgHiLight(byVal rg As Range, byVal hilite As Boolean)
Static mau as Byte
If hilite Then
mau = mau +1
If mau < 34 Or mau > 42 Then mau = 34
' set ...
Else
' reset ...
End If
End Sub

HieuCD · 22/1/18

AnhThu-1976 đã viết:
Các anh/chị và các bạn giúp trường hợp mà em đã mô tả trong File
Vì số lượng là rất nhiều, nên em muốn dùng code chứ không dùng CF để tránh nặng File
Em cảm ơn

Thử code

Mã:

Sub GPE()
  Dim dArr As Variant
  Dim S As Long, i As Long, ik As Long, n As Long
  i = Range("A" & Rows.Count).End(xlUp).Row
  If i < 9 Then Exit Sub
  dArr = Range("A1:A" & i).Value
  For i = 9 To UBound(dArr)
    If dArr(i, 1) <> "" And dArr(i, 1) <> dArr(i - 1, 1) Then
      S = 1
      For ik = i + 1 To UBound(dArr)
        If dArr(ik, 1) = dArr(ik - 1, 1) Then S = S + 1 Else Exit For
      Next ik
      If S > 10 Then
        Range("A" & i).Resize(S).Font.Color = vbRed
        n = n + 1
      Else
        Range("A" & i).Resize(S).Font.Color = 0
      End If
    End If
  Next i
  If n Then MsgBox "Có " & n & " phieu vuot quá 10 dòng"
End Sub

AnhThu-1976 · 22/1/18

Cảm ơn sự hỗ trợ của các anh chị!

HieuCD · 22/1/18

AnhThu-1976 đã viết:
Cảm ơn sự hỗ trợ của các anh chị!

Thay đổi một chút cho dể nhìn và chạy nhanh hơn

Mã:

Sub GPE1()
  Dim dArr As Variant, iColor As Byte
  Dim S As Long, i As Long, ik As Long, n As Long
  i = Range("A" & Rows.Count).End(xlUp).Row
  If i < 9 Then Exit Sub
  dArr = Range("A1:A" & i).Value
  Range("A9:A" & i).Font.Color = 0
  For i = 9 To UBound(dArr)
    If dArr(i, 1) <> "" And dArr(i, 1) <> dArr(i - 1, 1) Then
      S = 1
      For ik = i + 1 To UBound(dArr)
        If dArr(ik, 1) = dArr(ik - 1, 1) Then S = S + 1 Else Exit For
      Next ik
      If S > 10 Then
        iColor = ((iColor + 1) Mod 3) + 9
        Range("A" & i).Resize(S).Font.ColorIndex = iColor
        n = n + 1
      End If
      i = ik - 1
    End If
  Next i
  If n Then MsgBox "Có " & n & " phieu vuot quá 10 dòng"
End Sub

Chạy code tô màu cho dữ liệu trùng vượt quá 10 dữ liệu (1 người xem)

Người dùng đang xem chủ đề này

Thành viên tích cực

File đính kèm

Thành viên gắn bó

Huyền thoại GPE

Thành viên tích cực

Thành viên tích cực

Thành viên gắn bó

Huyền thoại GPE

/(hông là gì!

Thành viên tích cực

Thành viên gắn bó

Thành viên tích cực

Thành viên gắn bó

Cute Black Cat

Ăn cùng góc phố

Chuyên gia GPE

Thành viên tích cực

Chuyên gia GPE

Đếm ngược thời gian