Nhờ mọi người sửa giúp em đoạn code để tô màu dữ liệu trùng giúp em với ạ

Liên hệ QC

zPeterPan

Thành viên hoạt động
Tham gia
27/2/21
Bài viết
154
Được thích
10
Em chào tất cả thầy cô và anh chị em trên diễn đàn,
File này của em ngày trước đã được bạn @snow25 trợ giúp code để so sánh dữ liệu và tô màu.
Code chỉ đúng khi dữ liệu ngày tháng năm trong cột A của sheets"Data" liền nhau. Nhờ mọi người sửa đoạn code giúp em với ạ ( vì em không chuyên về viết code ạ ), em mò mẫm hơn 1 ngày rồi mà chưa ra được vấn đề nên em mới lập thêm bài viết mới để nhờ mọi người giúp đỡ ạ. Do số liệu trong file nhiều nên dung lượng file lớn nên em ví dụ minh hoạ vài dòng ạ.
Em có bảng dữ liệu như này:
12222222.jpg
và kết quả em mong muốn như này ạ:
Cột ngày 02/09/2021 của Sheet2 sẽ so sánh với dòng ngày 09/09/2021 của Sheet1 nếu có số 9487 thì sẽ tô màu đỏ
Cột ngày 09/09/2021 của Sheet2 sẽ so sánh với dòng ngày 16/09/2021 của Sheet1 nếu có số 9384 thì sẽ tô màu đỏ
Cột ngày 16/09/2021 của Sheet2 sẽ so sánh với dòng ngày 23/09/2021 của Sheet1 nếu có số 9184 thì sẽ tô màu đỏ
Cột ngày 23/09/2021 của Sheet2 sẽ so sánh với dòng ngày 30/09/2021 của Sheet1 nếu có số 9183 thì sẽ tô màu đỏ
Cột ngày 30/09/2021 của Sheet2 sẽ so sánh với dòng ngày 07/10/2021 của Sheet1 nếu có số 9762 thì sẽ tô màu đỏ
Cột ngày 07/10/2021 của Sheet2 sẽ so sánh với dòng ngày 14/10/2021 của Sheet1 nếu có số 2890 thì sẽ tô màu đỏ
Cột ngày 14/10/2021 của Sheet2 sẽ so sánh với dòng ngày 15/10/2021 của Sheet1 nếu có số 2375 thì sẽ tô màu đỏ
3232.jpg
và đây là code trong file ạ:
Mã:
Sub SoSanh()
Application.ScreenUpdating = False
   Dim i As Long, Lr As Long, arr, j As Long, dic As Object, t, dk As String, a As Long, Lc As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheet1
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:B" & Lr).Value
        For i = 1 To UBound(arr)
            a = CLng(CDate(arr(i, 1)))
            For Each t In Split(arr(i, 2), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("A" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 2 To Lr
           For j = 2 To Lc
               a = CLng(CDate(arr(2, j)))
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 3
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
Application.ScreenUpdating = True
End Sub
Kính mong mọi người sửa code giúp em với ạ. Em xin cảm ơn ạ.
 

File đính kèm

  • ToMau.xlsb
    3.4 MB · Đọc: 21
Lần chỉnh sửa cuối:
Cột ngày 02/09/2021 sẽ so sánh với dòng ngày 09/09/2021 nếu có số 9487 thì sẽ tô màu đỏ
cái vế đầu của dòng đầu là sheet data và vế sau là của sheet so sánh à. Tại mình đọc chưa hiểu.
Code kia bây giờ chạy thì nó thế nào? sai ở chỗ nào ạ,
Có thể giải thích thêm hoặc chờ tác giả vào sửa
 
Upvote 0
cái vế đầu của dòng đầu là sheet data và vế sau là của sheet so sánh à. Tại mình đọc chưa hiểu.
Code kia bây giờ chạy thì nó thế nào? sai ở chỗ nào ạ,
Có thể giải thích thêm hoặc chờ tác giả vào sửa
Tức là dữ liệu các dòng của cột ngày 02/09/2021 trong sheets "SoSanh" sẽ so sánh với số của dòng dòng ngày 09/09/2021 của sheets "Data" và các dòng của cột 02/09/2021 có số 9487 thì sẽ tô màu đỏ ạ
Bài đã được tự động gộp:

Tức là dữ liệu các dòng của cột ngày 02/09/2021 trong sheets "SoSanh" sẽ so sánh với số của dòng dòng ngày 09/09/2021 của sheets "Data" và các dòng của cột 02/09/2021 có số 9487 thì sẽ tô màu đỏ ạ
Code trong file chạy thi sẽ không tô màu gì ạ, nếu là ngày liên tục thì sẽ tô màu ví dụ( 02/09/2021->03/09/2021->04/09/2021-> ....), nhưng trường hợp ngày không liên tục thì sẽ không tô màu nếu trùng nhau ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Em chào tất cả thầy cô và anh chị em trên diễn đàn,
File này của em ngày trước đã được bạn @snow25 trợ giúp code để so sánh dữ liệu và tô màu.
Code chỉ đúng khi dữ liệu ngày tháng năm trong cột A của sheets"Data" liền nhau. Nhờ mọi người sửa đoạn code giúp em với ạ ( vì em không chuyên về viết code ạ ), em mò mẫm hơn 1 ngày rồi mà chưa ra được vấn đề nên em mới lập thêm bài viết mới để nhờ mọi người giúp đỡ ạ. Do số liệu trong file nhiều nên dung lượng file lớn nên em ví dụ minh hoạ vài dòng ạ.
Em có bảng dữ liệu như này:
View attachment 271688
và kết quả em mong muốn như này ạ:
Cột ngày 02/09/2021 của Sheet2 sẽ so sánh với dòng ngày 09/09/2021 của Sheet1 nếu có số 9487 thì sẽ tô màu đỏ
Cột ngày 09/09/2021 của Sheet2 sẽ so sánh với dòng ngày 16/09/2021 của Sheet1 nếu có số 9384 thì sẽ tô màu đỏ
Cột ngày 16/09/2021 của Sheet2 sẽ so sánh với dòng ngày 23/09/2021 của Sheet1 nếu có số 9184 thì sẽ tô màu đỏ
Cột ngày 23/09/2021 của Sheet2 sẽ so sánh với dòng ngày 30/09/2021 của Sheet1 nếu có số 9183 thì sẽ tô màu đỏ
Cột ngày 30/09/2021 của Sheet2 sẽ so sánh với dòng ngày 07/10/2021 của Sheet1 nếu có số 9762 thì sẽ tô màu đỏ
Cột ngày 07/10/2021 của Sheet2 sẽ so sánh với dòng ngày 14/10/2021 của Sheet1 nếu có số 2890 thì sẽ tô màu đỏ
Cột ngày 14/10/2021 của Sheet2 sẽ so sánh với dòng ngày 15/10/2021 của Sheet1 nếu có số 2375 thì sẽ tô màu đỏ
View attachment 271689
Kính mong mọi người sửa code giúp em với ạ. Em xin cảm ơn ạ.
Góp vui. Làm mò đoán ý, trúng chật hên sui.
Hãy thử xem
Nếu dòng nhảy 1 dòng thì cột nhảy 1 cột (không xét yếu tố ngày)

Mã:
Option Explicit

Sub ABC()
Dim i&, j&, t&, k&, LrD&, LrS&, Lc&
Dim Sh As Worksheet, Ws As Worksheet
Dim Temp, Key
Dim Rng As Range, eRng As Range

Application.ScreenUpdating = False

Set Sh = Sheets("Data")
LrD = Sh.Cells(Rows.Count, 1).End(3).Row

Set Ws = Sheets("Sheet1")
LrS = Ws.Cells(Rows.Count, 1).End(3).Row
Lc = Ws.Range("XFD2").End(xlToLeft).Column
For i = 3 To LrD
    For j = 3 To LrS
        If Ws.Cells(j, i - 1) = Sh.Cells(i, 2) Then
'           Set eRng = Ws.Cells(j, i - 1)
'           Set Rng = Union(eRng, Ws.Cells(j, i - 1))
            Ws.Cells(j, i - 1).Interior.ColorIndex = 5
        End If
    Next j
Next i
' Rng.Interior.ColorIndex = 2
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Góp vui. Làm mò đoán ý, trúng chật hên sui.
Hãy thử xem
Nếu dòng nhảy 1 dòng thì cột nhảy 1 cột (không xét yếu tố ngày)

Mã:
Option Explicit

Sub ABC()
Dim i&, j&, t&, k&, LrD&, LrS&, Lc&
Dim Sh As Worksheet, Ws As Worksheet
Dim Temp, Key
Dim Rng As Range, eRng As Range

Application.ScreenUpdating = False

Set Sh = Sheets("Data")
LrD = Sh.Cells(Rows.Count, 1).End(3).Row

Set Ws = Sheets("Sheet1")
LrS = Ws.Cells(Rows.Count, 1).End(3).Row
Lc = Ws.Range("XFD2").End(xlToLeft).Column
For i = 3 To LrD
    For j = 3 To LrS
        If Ws.Cells(j, i - 1) = Sh.Cells(i, 2) Then
'           Set eRng = Ws.Cells(j, i - 1)
'           Set Rng = Union(eRng, Ws.Cells(j, i - 1))
            Ws.Cells(j, i - 1).Interior.ColorIndex = 5
        End If
    Next j
Next i
' Rng.Interior.ColorIndex = 2
Application.ScreenUpdating = True
End Sub
thế biến "Lc" bị thừa ạ
 
Upvote 0
Góp vui. Làm mò đoán ý, trúng chật hên sui.
Hãy thử xem
Nếu dòng nhảy 1 dòng thì cột nhảy 1 cột (không xét yếu tố ngày)

Mã:
Option Explicit

Sub ABC()
Dim i&, j&, t&, k&, LrD&, LrS&, Lc&
Dim Sh As Worksheet, Ws As Worksheet
Dim Temp, Key
Dim Rng As Range, eRng As Range

Application.ScreenUpdating = False

Set Sh = Sheets("Data")
LrD = Sh.Cells(Rows.Count, 1).End(3).Row

Set Ws = Sheets("Sheet1")
LrS = Ws.Cells(Rows.Count, 1).End(3).Row
Lc = Ws.Range("XFD2").End(xlToLeft).Column
For i = 3 To LrD
    For j = 3 To LrS
        If Ws.Cells(j, i - 1) = Sh.Cells(i, 2) Then
'           Set eRng = Ws.Cells(j, i - 1)
'           Set Rng = Union(eRng, Ws.Cells(j, i - 1))
            Ws.Cells(j, i - 1).Interior.ColorIndex = 5
        End If
    Next j
Next i
' Rng.Interior.ColorIndex = 2
Application.ScreenUpdating = True
End Sub
Code này lấy file nào vậy bạn? sao không thấy sheets("sheet1") nhỉ
 
Upvote 0
Code này lấy file nào vậy bạn? sao không thấy sheets("sheet1") nhỉ
Đó là tôi tải file của chủ thót về và thêm Sheet1 để thử (vẫn muốn giữ nguyên Sheet SOSANH của bạn ấy)để so sánh với gốc-quên không Xóa sheet này và đoạn biến Lc.
Mọi người góp ý chân thành xin được cảm ơn, mong đừng ném đá.
 
Upvote 0
Đó là tôi tải file của chủ thót về và thêm Sheet1 để thử (vẫn muốn giữ nguyên Sheet SOSANH của bạn ấy)để so sánh với gốc-quên không Xóa sheet này và đoạn biến Lc.
Mọi người góp ý chân thành xin được cảm ơn, mong đừng ném đá.
nếu xử lý kiểu mảng có nhanh hơn không ạ, vì sheet "Data" sẽ có hơn 600 dòng, và sheet"SoSanh" sẽ có hơn 600 cột và hơn 560,000 dòng ạ
 
Upvote 0
Upvote 0
Em chào tất cả thầy cô và anh chị em trên diễn đàn,
File này của em ngày trước đã được bạn @snow25 trợ giúp code để so sánh dữ liệu và tô màu.
Code chỉ đúng khi dữ liệu ngày tháng năm trong cột A của sheets"Data" liền nhau. Nhờ mọi người sửa đoạn code giúp em với ạ ( vì em không chuyên về viết code ạ ), em mò mẫm hơn 1 ngày rồi mà chưa ra được vấn đề nên em mới lập thêm bài viết mới để nhờ mọi người giúp đỡ ạ. Do số liệu trong file nhiều nên dung lượng file lớn nên em ví dụ minh hoạ vài dòng ạ.
Em có bảng dữ liệu như này:
View attachment 271688
và kết quả em mong muốn như này ạ:
Cột ngày 02/09/2021 của Sheet2 sẽ so sánh với dòng ngày 09/09/2021 của Sheet1 nếu có số 9487 thì sẽ tô màu đỏ
Cột ngày 09/09/2021 của Sheet2 sẽ so sánh với dòng ngày 16/09/2021 của Sheet1 nếu có số 9384 thì sẽ tô màu đỏ
Cột ngày 16/09/2021 của Sheet2 sẽ so sánh với dòng ngày 23/09/2021 của Sheet1 nếu có số 9184 thì sẽ tô màu đỏ
Cột ngày 23/09/2021 của Sheet2 sẽ so sánh với dòng ngày 30/09/2021 của Sheet1 nếu có số 9183 thì sẽ tô màu đỏ
Cột ngày 30/09/2021 của Sheet2 sẽ so sánh với dòng ngày 07/10/2021 của Sheet1 nếu có số 9762 thì sẽ tô màu đỏ
Cột ngày 07/10/2021 của Sheet2 sẽ so sánh với dòng ngày 14/10/2021 của Sheet1 nếu có số 2890 thì sẽ tô màu đỏ
Cột ngày 14/10/2021 của Sheet2 sẽ so sánh với dòng ngày 15/10/2021 của Sheet1 nếu có số 2375 thì sẽ tô màu đỏ
View attachment 271689
và đây là code trong file ạ:
Mã:
Sub SoSanh()
Application.ScreenUpdating = False
   Dim i As Long, Lr As Long, arr, j As Long, dic As Object, t, dk As String, a As Long, Lc As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheet1
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:B" & Lr).Value
        For i = 1 To UBound(arr)
            a = CLng(CDate(arr(i, 1)))
            For Each t In Split(arr(i, 2), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("A" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 2 To Lr
           For j = 2 To Lc
               a = CLng(CDate(arr(2, j)))
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 3
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
Application.ScreenUpdating = True
End Sub
Kính mong mọi người sửa code giúp em với ạ. Em xin cảm ơn ạ.
Chỉnh tí xíu . . .
Mã:
Sub SoSanh()
  Application.ScreenUpdating = False
   Dim i As Long, Lr As Long, arr, j As Long, dic As Object, t, dk As String, a As Long, Lc As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheet1
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:B" & Lr).Value
        For i = 2 To UBound(arr)
            a = CLng(CDate(arr(i - 1, 1)))
            For Each t In Split(arr(i, 2), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("A" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 2 To Lr
           For j = 2 To Lc
               a = CLng(CDate(arr(2, j)))
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 3
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Chỉnh tí xíu . . .
Mã:
Sub SoSanh()
  Application.ScreenUpdating = False
   Dim i As Long, Lr As Long, arr, j As Long, dic As Object, t, dk As String, a As Long, Lc As Long
   Set dic = CreateObject("scripting.dictionary")
   With Sheet1
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:B" & Lr).Value
        For i = 2 To UBound(arr)
            a = CLng(CDate(arr(i - 1, 1)))
            For Each t In Split(arr(i, 2), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("A" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 2 To Lr
           For j = 2 To Lc
               a = CLng(CDate(arr(2, j)))
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 3
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
  Application.ScreenUpdating = True
End Sub
code không chạy được anh ạ
 
Upvote 0
Hơn 100K *8 ô, dùng vòng lặp dán tô màu từng ô thì hơi chua!
Mình làm thế này: Lấy A2 nối chuỗi với B3, trở thành chuỗi để so sánh: "44441|9487" (Chuỗi 1)
Sau đó bên sheet SoSanh, lấy từng ngày trên dòng 2 nối với từng ô của cột kế tiếp. So sánh với chuỗi 1, nếu giống thì lưu địa chỉ ô vào Collection.
Sau đó duyệt Collection để tô màu từng địa chỉ.
Hơi củ chuối nhưng mà ra kết quả nhé:
PHP:
Sub SoSanh()
Application.ScreenUpdating = False
Dim col As New Collection
Dim i&
Dim cell As Range, Rng As Range, cR As Range, Lv As String, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Data")
Set ws2 = Sheets("SoSanh")
Set Rng = ws2.Range("A2").CurrentRegion 'vung chua du lieu can to mau
    For Each cell In ws1.Range("B3:B" & ws1.Cells(Rows.Count, "B").End(xlUp).Row)
        Lv = cell.Offset(-1, -1).Value2 & "|" & cell ' Noi chuoi ngay tai A2 và so tai B3 (cot A và dong phia duoi tai cot B)
        For Each cR In ws2.Cells(3, 2).Resize(Rng.Rows.Count - 1, Rng.Columns.Count - 2) ' duyet qua tung o trong vung data
            If ws2.Cells(2, cR.Column).Value2 & "|" & cR = Lv Then ' Noi chuoi ngay tai dong tieu de cot truoc va so tai tung o, sau do so sanh voi Lv
                col.Add cR.Address(0, 0) ' luu dia chi o vao collection
            End If
        Next
    Next
    For i = 1 To col.Count ' duyet qua tung dia chi o luu trong collection
        ws2.Range(col(i)).Interior.Color = vbRed
    Next
Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • ToMau.xlsb
    3.4 MB · Đọc: 12
Upvote 0
Web KT

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

Back
Top Bottom