intersection

[Tatu]

Como posso encontrar dados na folha2 e fazer corresponder na folha1, encontrando a intersecção e preenchendo as células com cor

 

[DanteAmor]

Tente a seguinte macro:

Sub intersection_Dates()
  Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range
  Dim a As Variant, b As Variant, c As Variant, dic1 As Object, dic2 As Object
  Dim i As Long, j As Long, k As Long, nRow As Long
  
  Set sh1 = Sheets("Folha1")
  Set sh2 = Sheets("Folha2")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set rng = sh1.Range("A1")
  
  sh1.Range("D4", sh1.Cells(Rows.Count, Columns.Count)).Interior.Color = xlNone
  a = sh1.Range("A4", sh1.Range("A" & Rows.Count).End(3)).Value2
  b = sh1.Range("D3", sh1.Cells(3, Columns.Count).End(1)).Value2
  c = sh2.Range("A4", sh2.Cells(sh2.Range("A" & Rows.Count).End(3).Row, _
                      sh2.Cells(3, Columns.Count).End(1).Column)).Value2
  
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = i + 3   'rows
  Next
  For i = 1 To UBound(b, 2)
    dic2(b(1, i)) = i + 3   'columns
  Next
  
  For i = 1 To UBound(c, 1)
    If dic1.exists(c(i, 1)) Then
      nRow = dic1(c(i, 1))
      For j = 4 To UBound(c, 2) Step 2
        If c(i, j) = "" Then Exit For
        For k = c(i, j) To c(i, j + 1)
          If dic2.exists(k) Then Set rng = Union(rng, sh1.Cells(nRow, dic2(k)))
        Next k
      Next j
    End If
  Next i
  
  rng.Interior.Color = vbYellow
  sh1.Range("A1").Interior.Color = xlNone
End Sub

 

[Tatu]

Muito Obrigado :D

 

[DanteAmor]

Fico feliz em ajudá-lo, obrigado por comentar.