So sánh dữ liệu giữa sheet1 và Sheet 2 giống nhau thì cập ngày vào (1 người xem)

[HocVBAExcel]

So sánh dữ liệu giữa sheet1 và Sheet 2 giống nhau thì cập ngày tại cột B2 của sheet2 vào.
vd tại sheet 2 cột B4 & B5 giống với sheet 1 cột D4 & D8 thì nối ngày B2 của sheet2 vào.
Mình vừa tìm trên diễn đàn có đoạn code nhưng không biết sửa như thế nào

Public Sub Sosanh()
Dim I As Long, Arr(), dArr(), J As Long, K As Long, Tem As String
Set Dic = CreateObject("scripting.dictionary")
   With Sheet2
     Arr = .Range("B4", .[B65536].End(3)).Resize(, 4).Value
      End With
      For J = 1 To UBound(Arr, 2)
   For I = 1 To UBound(Arr)
   Tem = Arr(I, 1) & Arr(1, J)
      If Not Dic.exists(Tem) Then
          Dic.Add Tem, Empty
              End If
   Next
   Next
   With Sheet1
   dArr = .Range("B4", .[B65536].End(3)).Resize(, 4).Value
      End With
      For J = 1 To UBound(dArr, 2)
   For I = 1 To UBound(dArr)
   Tem = dArr(I, 1) & dArr(1, J)
      If Dic.exists(Tem) Then
            dArr(I, J) = dArr(I, J) & "(" & Sheet2.Range("B2") & ")"
      End If
      Next
      Next
   With Sheet1
   .[B4].Resize(I - 1, J - 1) = dArr
     End With
End Sub

Em có để kết quả trong file dính kèm

 

[giaiphap]

So sánh dữ liệu giữa sheet1 và Sheet 2 giống nhau thì cập ngày tại cột B2 của sheet2 vào.
vd tại sheet 2 cột B4 & B5 giống với sheet 1 cột C4 & C8 thì nối ngày B2 của sheet2 vào.
Em có để kết quả trong file dính kèm

Không biết phải ý bạn không? nhưng sau mình thấy có một ô bạn lấy ví dụ chưa đúng.

 

[bd1808]

Bạn thử code này nhé

Sub TimKiem()
    Dim nRow As Integer, nCol As Integer, nNewCol As Integer, i As Integer, j As Integer, k As Integer, rngData As Range
    Sheet2.Activate
    Range("B5").Select
    Set rngData = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
   
    Sheet1.Activate
    nRow = 5
    nCol = 2
    nNewCol = 12
    i = 0
    While Not IsEmpty(Cells(nRow, nCol + i))
        j = 0
        While Not IsEmpty(Cells(nRow + j, nCol + i))
            Cells(nRow + j, nCol + i + nNewCol) = IIf(WorksheetFunction.CountIf(rngData, Cells(nRow + j, nCol + i)) > 0, Cells(nRow + j, nCol + i) + "(" + Trim(Str(Sheet2.Range("B2")) + ")"), Cells(nRow + j, nCol + i))
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

PS: trong VD bạn đưa bị sai vài chỗ (chắc do làm bằng tay nên chưa chính xác ): ô L6, J5, J7, I13, I14.

 

[HocVBAExcel]

Bạn thử code này nhé

Sub TimKiem()
    Dim nRow As Integer, nCol As Integer, nNewCol As Integer, i As Integer, j As Integer, k As Integer, rngData As Range
    Sheet2.Activate
    Range("B5").Select
    Set rngData = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
   
    Sheet1.Activate
    nRow = 5
    nCol = 2
    nNewCol = 12
    i = 0
    While Not IsEmpty(Cells(nRow, nCol + i))
        j = 0
        While Not IsEmpty(Cells(nRow + j, nCol + i))
            Cells(nRow + j, nCol + i + nNewCol) = IIf(WorksheetFunction.CountIf(rngData, Cells(nRow + j, nCol + i)) > 0, Cells(nRow + j, nCol + i) + "(" + Trim(Str(Sheet2.Range("B2")) + ")"), Cells(nRow + j, nCol + i))
            j = j + 1
        Wend
        i = i + 1
    Wend
End Sub

PS: trong VD bạn đưa bị sai vài chỗ (chắc do làm bằng tay nên chưa chính xác ): ô L6, J5, J7, I13, I14.

Cám ơn anh đã giúp em.
Mình bổ sung lại file nhờ anh chỉ dẫn thêm,mình tìm trên diễn đàn chỉnh sửa nhưng vẫn chưa được như mong muốn,
Mình muốn khi chọn list tại cột B4 của sheet2 sau đó nhấn nút lệnh thì kết quả đúng điều kiện ở cột mà có mã giống B4 của sheet2.Còn đây là đoạn code đang thực hiện.

Private Sub CommandButton1_Click()
Dim I As Long, Arr(), dArr(), tArr(), J As Long, K As Long, Tem As String
Set Dic = CreateObject("scripting.dictionary")
    With Sheet1
      K = .Range("B3").Value
    End With
 '----------------------------------------------------------
    '[COLOR=#008000]With Sheet1
       'tArr = .Range("B4", .[B4].End(xlToRight)).Value
    'End With
      'For K = 1 To UBound(tArr, 2)
          'Tem = tArr(1, K)
            'If Not Dic.Exists(Tem) Then Dic.Add Tem, K
         'Next [/COLOR]
'----------------------------------------------------------
   With Sheet2
     Arr = .Range("A5", .[A65536].End(3)).Offset(, 1)
      End With
   For I = 1 To UBound(Arr)
   Tem = Arr(I, 1)
      If Not Dic.Exists(Tem) Then
          Dic.Add Tem, Empty
              End If
   Next
'----------------------------------------------------------
   With Sheet1
   dArr = .Range("A5", .[A65536].End(3)).Offset(, K)
      End With
   For I = 1 To UBound(dArr)
   Tem = dArr(I, 1)
     If dArr(I, 1) <> "" Then
      If Dic.Exists(Tem) Then
            dArr(I, 1) = dArr(I, 1) & "(" & Sheet2.Range("B2") & ")"
        End If
        End If
      Next
   With Sheet1
   .[A5].Offset(, K).Resize(I - 1) = dArr
     End With
End Sub