Thank's !!
im solved in
http://www.excelforum.com/excel-prog...91#post2790691
Code:
Sub ASSummary()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rngBase1 As Range
Dim rngBase2 As Range
Dim rngCell As Range
Dim lngQty As Long
Set ws1 = ActiveWorkbook.Sheets("Base_1")
Set ws2 = ActiveWorkbook.Sheets("Base_2")
Set wsSum = ActiveWorkbook.Sheets("Resumo")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With ws1
Set rngBase1 = .Range("B2", .Range("B2").End(xlDown))
End With
With ws2
Set rngBase2 = .Range("B2", .Range("B2").End(xlDown))
End With
For Each rngCell In rngBase1
lngQty = rngCell.Offset(0, -1).Value
Set rngFound = ws2.Columns(2).Find(What:=rngCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows)
If Not rngFound Is Nothing Then
lngQty = lngQty + rngFound.Offset(0, -1).Value
End If
With wsSum
Set rngDest = .Range("A2000").End(xlUp).Offset(1)
End With
rngDest.Value = lngQty
rngDest.Offset(0, 1) = rngCell
rngDest.Offset(0, 2) = rngCell.Offset(0, 1)
Next
For Each rngCell In rngBase2
Set rngFound = ws1.Columns(2).Find(What:=rngCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows)
If rngFound Is Nothing Then
With wsSum
Set rngDest = .Range("A2000").End(xlUp).Offset(1)
End With
rngCell.Offset(0, -1).Resize(1, 3).Copy
rngDest.Resize(1, 3).PasteSpecial xlPasteValues
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub