babdallas escreveu:Tente assim
Código: Selecionar todosSub LooparArquivos()
Dim objFSO As Object
Dim vrtFile As Variant
Dim strCaminho As String
Dim wbkFile As Workbook
'Caminho da pasta de trabalho
strCaminho = "C:\MinhaPasta"
'Instanciando o objeto FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Loop pelos arquivos da pasta
For Each vrtFile In objFSO.GetFolder(strCaminho).Files
If Right(vrtFile.Name, 4) = "xlsm" Then
Set wbkFile = Workbooks.Open(Filename:=vrtFile.Path)
'Coloque aqui seu código
wbkFile.Close SaveChanges:=True
End If
Next vrtFile
End Sub
Showwwwwwww irmão!
Em 10 min seu código me ajudou a executar a macro em 750 arquivos e nem precisei abri-los. Tenho o resto da semana livre
ia ter que fazer as modificações uma a uma.
Agora, pra ir pro 10! Gostaria que ao executar sua macro, ele me perguntasse onde (em que pasta) estão os arquivos, a a partir daí executasse automaticamente.
Abaixo cito um código que faz isso. Essa macro unifica todos arquivos na mesma planilha. Mas não sei qual parte do código devo isolar para que essa sua macro me solicite o local primeiramente:
Código: Selecionar todos'UnificarPlanilhas Macro
Sub lsUnificarPlanilhas()
On Error GoTo Sair
Dim lUltimaColunaAtiva As Long
Dim lUltimaLinhaAtiva As Long
Dim lRng As Range
Dim sPath As String
Dim fName As String
Dim lNomeWB As String
Dim lIPlan As Integer
Dim lUltimaLinhaPlanDestino As Long
PlanilhaDestino = ThisWorkbook.Name
sPath = Localizar_Caminho
sName = Dir(sPath & "\*.xl*")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Do While sName <> ""
fName = sPath & "\" & sName
Workbooks.Open Filename:=fName, UpdateLinks:=False
lNomeWB = ActiveWorkbook.Name
For lIPlan = 1 To ActiveWorkbook.Sheets.Count
Workbooks(lNomeWB).Worksheets(lIPlan).Activate
lUltimaLinhaAtiva = Cells(Rows.Count, 1).End(xlUp).Row
lUltimaColunaAtiva = ActiveSheet.Cells(1, 5000).End(xlToLeft).Column
Set lRng = Range(Cells(1, lUltimaColunaAtiva).Address)
Range("A" & 1 & ":" & gfLetraColuna(lRng) & lUltimaLinhaAtiva).Select
Selection.Copy
Workbooks(PlanilhaDestino).Worksheets(1).Activate
lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row
If lUltimaLinhaPlanDestino > 1 Then
lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
Range("A" & lUltimaLinhaPlanDestino).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next lIPlan
Workbooks(lNomeWB).Close SaveChanges:=False
sName = Dir()
Loop
MsgBox "Planilhas unificadas!"
Sair:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
-------
Function gfLetraColuna(ByVal rng As Range) As String
Dim lTexto() As String
lTexto = Split(rng.Address, "$")
gfLetraColuna = lTexto(1)
End Function
----------
Public Function Localizar_Caminho() As String
Dim strCaminho As String
With Application.FileDialog(msoFileDialogFolderPicker)
'Permitir mais de uma pasta
.AllowMultiSelect = False
'Mostrar janela
.Show
If .SelectedItems.Count > 0 Then
strCaminho = .SelectedItems(1)
End If
End With
'Atribuir caminho a variável
Localizar_Caminho = strCaminho
End Function
Grato!
