So sánh dữ liệu giữa 2 sheets và tô màu dữ liệu trùng

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 xin nhờ các Thầy cô và các Anh chị em trên diễn đàn giúp em với ạ. . .
Từ bài viết Tách chuỗi và ghép vị trí được sự giúp đỡ của bác @Ba Tê . . .
Em muốn so sánh dữ liệu của các cột ngày trong Sheets"Ghep Vi Tri" với dữ liệu ngày ở cột D trong Sheets" Tach Vi Tri" và những số nào trùng sẽ tô màu vào ô trùng trong Sheets"Ghep Vi Tri"
Ví dụ là: Các số của cột ngày 01/03/2020 của Sheets"Ghep Vi Tri", sẽ so sánh với với ngày 02/03/2020 cột ("D") của Sheets" Tach Vi Tri", nếu số nào trùng thì tô màu vào ô đó trong Sheets"Ghep Vi Tri" . . .
Do số liệu nhiều nên em chỉ so sánh 4 ngày của sheets" Ghep Vi Tri" ạ. . .
Nhờ mọi người giúp em với ạ. . . Em xin cảm ơn ạ. . .

2.JPG
1.JPG
 

File đính kèm

  • DoiChieu.xlsb
    4.9 MB · Đọc: 29
Lần chỉnh sửa cuối:
Sao đăng nhiều bài vậy?


Hình như là thống kê con số gì hả?
 
Upvote 0
Sao đăng nhiều bài vậy?


Hình như là thống kê con số gì hả?
2 bài tiêu đề và nội dung em hỏi khác nhau mà bác. . .
Bài bên đấy là tách và thống kê
Còn bài này là so sánh dữ liệu ạ
 
Upvote 0
Em xin nhờ các Thầy cô và các Anh chị em trên diễn đàn giúp em với ạ. . .
Từ bài viết Tách chuỗi và ghép vị trí được sự giúp đỡ của bác @Ba Tê . . .
Em muốn so sánh dữ liệu của các cột ngày trong Sheets"Ghep Vi Tri" với dữ liệu ngày ở cột D trong Sheets" Tach Vi Tri" và những số nào trùng sẽ tô màu vào ô trùng trong Sheets"Ghep Vi Tri"
Ví dụ là: Các số của cột ngày 01/03/2020 của Sheets"Ghep Vi Tri", sẽ so sánh với với ngày 02/03/2020 cột ("D") của Sheets" Tach Vi Tri", nếu số nào trùng thì tô màu vào ô đó trong Sheets"Ghep Vi Tri" . . .
Do số liệu nhiều nên em chỉ so sánh 4 ngày của sheets" Ghep Vi Tri" ạ. . .
Nhờ mọi người giúp em với ạ. . . Em xin cảm ơn ạ. . .

View attachment 263246
View attachment 263247
Do code tô màu chạy hơi lâu chút bạn xem có đúng không.
Mã:
Sub tomau()
   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 Sheets("tach vi tri")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B3:D" & lr).Value
        For i = 1 To UBound(arr)
            a = CLng(arr(i, 1))
            For Each T In Split(arr(i, 3), ",")
                dk = a & "#" & T
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheets("ghep vi tri")
       lc = .Range("XFD2").End(xlToLeft).Column
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(lr, lc).Interior.ColorIndex = 0
       For i = 3 To lr
           For j = 2 To lc
               a = CLng(.Cells(2, j).Value) + 1
               dk = a & "#" & .Cells(i, j).Value
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 4
               End If
           Next j
      Next i
   End With
End Sub
 
Upvote 0
Do code tô màu chạy hơi lâu chút bạn xem có đúng không.
Mã:
Sub tomau()
   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 Sheets("tach vi tri")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B3:D" & lr).Value
        For i = 1 To UBound(arr)
            a = CLng(arr(i, 1))
            For Each T In Split(arr(i, 3), ",")
                dk = a & "#" & T
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheets("ghep vi tri")
       lc = .Range("XFD2").End(xlToLeft).Column
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(lr, lc).Interior.ColorIndex = 0
       For i = 3 To lr
           For j = 2 To lc
               a = CLng(.Cells(2, j).Value) + 1
               dk = a & "#" & .Cells(i, j).Value
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 4
               End If
           Next j
      Next i
   End With
End Sub
Nếu cho Sheets("Ghep Vi Tri") vào mảng thì có nhanh hơn không ạ. . .
 
Upvote 0
Nếu cho Sheets("Ghep Vi Tri") vào mảng thì có nhanh hơn không ạ. . .
.........................................
Mã:
Option Explicit

Sub Macro2()
Sheet2.Activate
Range("B3").Select
With Range("B3:CV11344")
    .Interior.ColorIndex = 0
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
      "=(LEN(INDEX('Tach Vi Tri'!$D$3:$D$533,MATCH(B$2,'Tach Vi Tri'!$B$3:$B$533,0)))-LEN(SUBSTITUTE(INDEX('Tach Vi Tri'!$D$3:$D$533,MATCH(B$2,'Tach Vi Tri'!$B$3:$B$533,0)),B3,"""")))>0"
    With .FormatConditions(.FormatConditions.Count)
        .SetFirstPriority
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = 0.399945066682943
            .PatternTintAndShade = 0
        End With
    End With
End With
End Sub
 
Upvote 0
.........................................
Mã:
Option Explicit

Sub Macro2()
Sheet2.Activate
Range("B3").Select
With Range("B3:CV11344")
    .Interior.ColorIndex = 0
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
      "=(LEN(INDEX('Tach Vi Tri'!$D$3:$D$533,MATCH(B$2,'Tach Vi Tri'!$B$3:$B$533,0)))-LEN(SUBSTITUTE(INDEX('Tach Vi Tri'!$D$3:$D$533,MATCH(B$2,'Tach Vi Tri'!$B$3:$B$533,0)),B3,"""")))>0"
    With .FormatConditions(.FormatConditions.Count)
        .SetFirstPriority
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = 0.399945066682943
            .PatternTintAndShade = 0
        End With
    End With
End With
End Sub
Cảm ơn bác @CHAOQUAY . Nhưng đối chiếu như vậy sai ạ. . . và có 27 vị trí ghép là bôi màu hết hơn 500 ngày , em đối chiếu thủ công thì chỉ trùng > 10 ngày và < 20 ngày thôi ạ. . . 123.JPG
 
Upvote 0
Nếu cho Sheets("Ghep Vi Tri") vào mảng thì có nhanh hơn không ạ. . .
Cho vào mảng có vẻ nhanh hơn bằng 1/2 thời gian không cho vào mảng.
Mã:
Sub tomau()
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 Sheets("tach vi tri")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B3:D" & lr).Value
        For i = 1 To UBound(arr)
            a = CLng(arr(i, 1))
            For Each T In Split(arr(i, 3), ",")
                dk = a & "#" & T
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheets("ghep vi tri")
       lc = .Range("XFD2").End(xlToLeft).Column
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(lr, lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(lr, lc).Value
       For i = 3 To lr
           For j = 2 To lc
               a = CLng(arr(2, j)) + 1
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 4
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
   Application.ScreenUpdating = True
End Sub
 
Upvote 0
Cho vào mảng có vẻ nhanh hơn bằng 1/2 thời gian không cho vào mảng.
Mã:
Sub tomau()
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 Sheets("tach vi tri")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B3:D" & lr).Value
        For i = 1 To UBound(arr)
            a = CLng(arr(i, 1))
            For Each T In Split(arr(i, 3), ",")
                dk = a & "#" & T
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheets("ghep vi tri")
       lc = .Range("XFD2").End(xlToLeft).Column
       lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(lr, lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(lr, lc).Value
       For i = 3 To lr
           For j = 2 To lc
               a = CLng(arr(2, j)) + 1
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 4
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
   Application.ScreenUpdating = True
End Sub
Bác @snow25 ơi, khi em so sánh để tô màu 3 số thì bị lỗi này ạ, bác có thể sửa giúp em được không ạ, em cảm ơn nhiều ạ.1234.jpg
 

File đính kèm

  • DoiChieu.xlsb
    1.7 MB · Đọc: 9
Upvote 0
Upvote 0
Bác @snow25 ơi, khi em so sánh để tô màu 3 số thì bị lỗi này ạ, bác có thể sửa giúp em được không ạ, em cảm ơn nhiều ạ.View attachment 271595
Thử code.
Mã:
Sub ToMau()
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, m As Long
   m = Timer
   Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
   With Sheet1
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B4:D" & Lr).Value
        For i = 1 To UBound(arr)
            a = CLng(CDate(arr(i, 1)))
            For Each t In Split(arr(i, 3), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
      .AutoFilterMode = False
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 3 To Lr
           For j = 2 To Lc
               a = CLng(arr(2, j)) + 1
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 46
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox Timer - m
End Sub
 
Upvote 0
Thử code.
Mã:
Sub ToMau()
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, m As Long
   m = Timer
   Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
   With Sheet1
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B4:D" & Lr).Value
        For i = 1 To UBound(arr)
            a = CLng(CDate(arr(i, 1)))
            For Each t In Split(arr(i, 3), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
      .AutoFilterMode = False
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 3 To Lr
           For j = 2 To Lc
               a = CLng(arr(2, j)) + 1
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 46
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox Timer - m
End Sub
code này lại không thấy tô màu cell anh ạ.
 
Upvote 0
code này lại không thấy tô màu cell anh ạ.
Thử code.
Mã:
Sub ToMau()
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, m As Long
   m = Timer
   Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
   With Sheet1
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B4:D" & Lr).Value
        For i = 1 To UBound(arr)
            a = CLng(CDate(arr(i, 1)))
            For Each t In Split(arr(i, 3), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
      .AutoFilterMode = False
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 3 To Lr
           For j = 2 To Lc
               a = CLng(arr(2, j)) + 1
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 46
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox Timer - m
End Sub
[/CODE
[/QUOTE]
bác có thể sửa code giúp em để nếu cột ngày mà không liền nhau trong Sheets" Tach Vi Tri" thì Sheets"Ghep Vi Tri" vẫn chọn tô màu được không ạ.
Ví dụ:
Các số của cột ngày 09/11/2021 của Sheets"Ghep Vi Tri", sẽ so sánh với số của ngày 16/11/2021 cột ("D") của Sheets" Tach Vi Tri"
có thể ngày sẽ không được cách đều nhau, mà dòng trên và dòng dưới thôi ạ. Em cảm ơn bác nhiều
bác có thể sửa code giúp em để nếu cột ngày mà không liền nhau trong Sheets" Tach Vi Tri" thì Sheets"Ghep Vi Tri" vẫn chọn tô màu được không ạ.
Ví dụ:
Các số của cột ngày 09/11/2021 của Sheets"Ghep Vi Tri", sẽ so sánh với số của ngày 16/11/2021 cột ("D") của Sheets" Tach Vi Tri"
có thể ngày sẽ không được cách đều nhau, mà dòng trên và dòng dưới thôi ạ. Em cảm ơn bác nhiều[/CODE]
 
Lần chỉnh sửa cuối:
Upvote 0
Thử code.
Mã:
Sub ToMau()
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, m As Long
   m = Timer
   Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
   With Sheet1
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B4:D" & Lr).Value
        For i = 1 To UBound(arr)
            a = CLng(CDate(arr(i, 1)))
            For Each t In Split(arr(i, 3), ",")
                dk = a & "#" & t
                dic.Item(dk) = i
            Next
       Next i
   End With
   With Sheet2
      .AutoFilterMode = False
       Lc = .Range("XFD2").End(xlToLeft).Column
       Lr = .Range("B" & Rows.Count).End(xlUp).Row
       .Cells(1, 1).Resize(Lr, Lc).Interior.ColorIndex = 0
       arr = .Cells(1, 1).Resize(Lr, Lc).Value
       For i = 3 To Lr
           For j = 2 To Lc
               a = CLng(arr(2, j)) + 1
               dk = a & "#" & arr(i, j)
               If dic.exists(dk) Then
                  .Cells(i, j).Interior.ColorIndex = 46
               End If
           Next j
      Next i
   End With
   Set dic = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox Timer - m
End Sub
Bác có thể sửa code giúp em để nếu cột ngày mà không liền nhau trong Sheets" Tach Vi Tri" thì Sheets"Ghep Vi Tri" vẫn chọn tô màu được không ạ.
Ví dụ:
Các số của cột ngày 09/11/2021 của Sheets"Ghep Vi Tri", sẽ so sánh với số của ngày 16/11/2021 cột ("D") của Sheets" Tach Vi Tri"
có thể ngày sẽ không được cách đều nhau, mà dòng trên và dòng dưới thôi ạ. Em cảm ơn bác nhiều
 
Upvote 0
Web KT

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

Back
Top Bottom