Bom, como tem muitos que não podem ou não conseguem fazer o download da planilha, segue aqui o codigo que estou na luta para ajustar conforme a necessidade que disse...
Option Explicit
Dim g, p As Variant
Dim sh As Worksheet
Dim shName, shRdo, busca, busca2, firstaddress, resultado, pasta As String
Sub Atualiza()
Dim linha, UltimaLinha, UltimaLinha1, COLUNA, lastRow, lastRow1 As Integer, lResult, cResult, i As Long
Dim Valores As String
Dim c As Object
linha = 6
COLUNA = 2
linhaRl = 10
shRdo = ActiveSheet.Name
For Each sh In Worksheets
p = "."
If Right(sh.Name, 1) = p Then
shName = sh.Name
busca = Sheets(shName).Cells(linha, 1)
busca2 = Sheets(shName).Cells(linha - 1, 1) & busca ' Busca Concatenada
lastRow = Sheets(shName).Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1
With Worksheets(shRdo).Range("B5:B65000") 'aqui não teria precisão da quantidade de linhas, pois o usuário poderia inserir linhas
Set c = .Find(what:=busca2, LookIn:=xlValues, SearchOrder:=xlByRows)
If Not c Is Nothing Then
firstaddress = c.Address
resultado = c
cResult = c.Column
lResult = c.Row
Do
With Sheets(shName)
.Cells(lastRow, 1) = resultado
.Cells(lastRow, 2) = Sheets(shRdo).Cells(lResult, cResult + 4)
.Cells(lastRow, 3) = Sheets(shRdo).Cells(lResult, cResult + 3)
.Cells(lastRow, 4) = Sheets(shRdo).Cells(lResult, cResult + 8)
.Cells(lastRow, 5) = Sheets(shRdo).Cells(lResult, cResult + 7)
.Cells(lastRow, 6) = CDbl(Sheets(shRdo).Cells(lResult, cResult + 7)) + CDbl(Sheets(shRdo).Cells(lResult, cResult + 8))
.Cells(lastRow, 7).Value = shRdo
End With
Set c = .FindNext(c)
cResult = c.Column
lResult = c.Row
busca = ""
busca2 = ""
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
Next
Set c = Nothing
End Sub
Postado : 14/05/2013 10:52 am