intersection

Tatu

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

Attachments

• 187.6 KB Views: 6
• 198.3 KB Views: 6

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

DanteAmor

Well-known Member
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
Fico feliz em ajudá-lo, obrigado por comentar.