Veja se lhe atende.
Sub ProcuraCSN()
Dim k As Long, v As Long, x As Long, m As Long, strD As String
Application.ScreenUpdating = False
AddZero
With Sheets("PLan3")
If .[R2] <> "" Then .Range("R2", .Cells(Rows.Count, "R").End(3)) = ""
m = 2
For k = 2 To 137
strD = Join(Application.Index(.Cells(k, 1).Resize(, 15).Value, 1, 0), " ")
DoEvents
For x = 2 To 11 Step 3
For v = m To 268761 - 731240 * (x < 11)
If strD = Trim(Sheets("CSN").Cells(v, x)) Then
.Cells(k, 18) = Sheets("CSN").Cells(v, x).Offset(, -1).Value
m = v + 1
GoTo próxK
End If
Next v
Next x
próxK:
Next k
End With
Complemento
End Sub
'processa as combinações não encontradas pelo código ProcuraCSN
Sub Complemento()
Dim r As Range, v As Long, x As Long, m As Long, strD As String
With Sheets("PLan3")
m = 2
Do While Application.CountA(.[R2:R137]) < 136
For Each r In .[R2:R137].SpecialCells(4)
strD = Join(Application.Index(.Cells(r.Row, 1).Resize(, 15).Value, 1, 0), " ")
DoEvents
For x = 2 To 11 Step 3
For v = m To 268761 - 731240 * (x < 11)
If strD = Trim(Sheets("CSN").Cells(v, x)) Then
r.Value = Sheets("CSN").Cells(v, x).Offset(, -1).Value
m = v + 1
GoTo próxr
End If
Next v
Next x
próxr:
If r.Value = "" Then m = 2
Next r
Loop
End With
End Sub
'adiciona zero no início dos díitos únicos na planilha Plan3
Sub AddZero()
Dim r As Range
For Each r In Sheets("Plan3").[A2:I137]
If Len(r.Value) = 1 Then
r.NumberFormat = "@"
r.Value = 0 & r.Value
End If
Next r
End Sub
Execute apenas o primeiro código, pois os outros dois serão "chamados" por ele.
Postado : 23/09/2025 1:46 pm