Olá amigos
De antemão agradeço a atenção.
Ano passado usei esse mesmo código e funcionou normalmente, esse ano é que está dando a mensagem que não encontra o caminho, por isso não tinha copiado o código inteiro, mas copiei agora para vocês verificarem.
Este código tem como objetivo ler um ou mais arquivos que se encontra na pasta "C:Usersto9zDocumentsTeste" e para cada arquivo encontrado ele grava as informações obtidas de outro arquivo.
Segue o código completo.
Sub atualizaMETA2015()
'***************************
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook
Dim sheetCount As Integer
Dim strDir, strFileType, nomeProjeto As String
Dim ss As SearchScope
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
.SearchSubFolders = True
'Change path to suit
.LookIn = "C:Usersto9zDocumentsTeste"
strDir = .LookIn
.FileType = msoFileTypeExcelWorkbooks
'Optional filter w ith wildcard
.Filename = "*-custos.xls"
strFileType = .Filename
MsgConfirm = MsgBox("A macro executará as modificações a partir dos seguintes critérios:" & Chr(13) & Chr(13) & strDir & Chr(13) & Chr(13) & "Com a seguinte configuração de busca:" & Chr(13) & Chr(13) & strFileType, vbOKCancel)
MsgBox (.Execute & " arquivos encontrados. Clique OK para iniciar a operação.")
If MsgConfirm = 1 Then
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
wbResults.Activate
ActiveSheet.Unprotect
Sheets("PROJETO").Select
'*************** DO YOUR CODE HERE
'Procedimento que adiciona as formulas para buscar valores da META 2013
'Ver caminho do arquivo de Meta
'Buscar valores via PROCV na planilha META
'localizada em \petrobras.bizPetrobrasUO-SEALUO-SEAL_ATP-ST_PRGCRESERVADAProjetosBase CustosHistorico
'a planilha META deve estar aberta quando rodar esta MACRO
Range("CT5").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERR(VLOOKUP(LEFT(R1C2,6),'[Meta.xls]META 2014'!R2C1:R150C16,R[-2]C[-53]+2,FALSE)),0,VLOOKUP(LEFT(R1C2,6),'[Meta.xls]META 2014'!R2C1:R150C16,R[-2]C[-53]+2,FALSE))"
Range("CT5").Select
Selection.AutoFill Destination:=Range("CT5:DE5"), Type:=xlFillValues
Range("CT5:DE5").Select
'Formula de soma da META 2014
Range("DF5").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
Range("DF6").Select
'Copiar e colar como valores para remover as formulas
Range("CT5:DE5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Apagar META 2015
Range("CG5:CR5").Select
Selection.Clear
'*************** END CODE
Sheets("MENU").Select
'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:= _
' False, AllowFiltering:=True
wbResults.Close SaveChanges:=True
Next lCount
End If
End If
End With
On Error GoTo 0
'MsgBox (Err.Description & " : " & Err.Number)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Postado : 15/01/2015 11:54 am