intersection

Tatu

New Member
Joined
Jun 18, 2020
Messages
6
Como posso encontrar dados na folha2 e fazer corresponder na folha1, encontrando a intersecção e preenchendo as células com cor
 

Attachments

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,921
Office Version
2007
Platform
Windows
Tente a seguinte macro:

VBA Code:
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,921
Office Version
2007
Platform
Windows
Fico feliz em ajudá-lo, obrigado por comentar.
 

Watch MrExcel Video

Forum statistics

Threads
1,100,037
Messages
5,472,115
Members
406,804
Latest member
xbinsx

This Week's Hot Topics

Top