Consegui desse jeito, mas possivelmente deve ter um código mais simplificado.
O que vale é o esforço rsrs
Sub Teste()
Application.ScreenUpdating = False
Dim A As Double, B As Double, C As Double, D As Double
A = 2
Do While Plan1.Cells(A, 13) <> ""
Contrato = Plan1.Cells(A, 13)
For B = 2 To 20000
If Plan1.Cells(B, 4) = "" Then Exit For
If Plan1.Cells(B, 4) = Contrato And Plan1.Cells(B, 10) <> 0 Then
UltimaLinha = Range("O1048576").End(xlUp).Offset(1, 0).Row
Empreendimento1 = Plan1.Cells(B, 3)
Cliente1 = Plan1.Cells(B, 5)
Data1 = Plan1.Cells(B, 11)
Valor1 = Plan1.Cells(B, 10)
Plan1.Cells(UltimaLinha, 15) = Empreendimento1
Plan1.Cells(UltimaLinha, 16) = Contrato
Plan1.Cells(UltimaLinha, 17) = Cliente1
Plan1.Cells(UltimaLinha, 18) = Valor1
Plan1.Cells(UltimaLinha, 19) = Data1
Exit For
End If
Next
For C = 2 To 20000
If Plan1.Cells(C, 4) = "" Then Exit For
If Plan1.Cells(C, 4) = Contrato And Plan1.Cells(C, 10) <> Valor1 And Plan1.Cells(C, 11) > Data1 Then
UltimaLinha = Range("O1048576").End(xlUp).Offset(1, 0).Row
Empreendimento2 = Plan1.Cells(C, 3)
Cliente2 = Plan1.Cells(C, 5)
Data2 = Plan1.Cells(C, 11)
Valor2 = Plan1.Cells(C, 10)
Plan1.Cells(UltimaLinha, 15) = Empreendimento2
Plan1.Cells(UltimaLinha, 16) = Contrato
Plan1.Cells(UltimaLinha, 17) = Cliente2
Plan1.Cells(UltimaLinha, 18) = Valor2
Plan1.Cells(UltimaLinha, 19) = Data2
Exit For
End If
Next
For D = 2 To 20000
If Plan1.Cells(D, 4) = "" Then Exit For
If Plan1.Cells(D, 4) = Contrato And Plan1.Cells(D, 10) <> Valor1 And Plan1.Cells(C, 11) > Data1 Then
If Plan1.Cells(D, 4) = Contrato And Plan1.Cells(D, 10) <> Valor2 And Plan1.Cells(C, 11) > Data2 Then
UltimaLinha = Range("O1048576").End(xlUp).Offset(1, 0).Row
Empreendimento3 = Plan1.Cells(D, 3)
Cliente3 = Plan1.Cells(D, 5)
Data3 = Plan1.Cells(D, 11)
Valor3 = Plan1.Cells(D, 10)
Plan1.Cells(UltimaLinha, 15) = Empreendimento3
Plan1.Cells(UltimaLinha, 16) = Contrato
Plan1.Cells(UltimaLinha, 17) = Cliente3
Plan1.Cells(UltimaLinha, 18) = Valor3
Plan1.Cells(UltimaLinha, 19) = Data3
Exit For
End If
End If
Next
A = A + 1
Loop
Application.ScreenUpdating = True
End Sub
Postado : 11/03/2015 9:22 pm