Sincero16

Ola pessoal estou trabalhando nessa macro que preciso abrir vários arquivos no Excel e copiar os dados da colunas A2 e B2 que possuem dados de todas planilhas porém tem alguns possuem mais planilhas que outros programei e ele funciona porém estou com problema na Do While pois eu programei para se em uma planilha que não tenha valores para ir para a próxima planilha, no entanto quando chega na ultima planilha da erro. Agradeço a Ajuda abaixo esta o código Private Sub BtPlaca_Click() Dim FSO As Object Dim Pasta As String Dim Planilha As Object Dim OpenBook As String Dim UltCel As Range Dim W As Worksheet Dim x As Integer 'Achar útima celula Set UltCel = Range("A1048576").End(xlUp) UltCel.Select ActiveCell.Offset(1, 0).Select Set FSO = CreateObject("Scripting.FileSystemObject") Pasta = "C:\Users\Desktop\Base\" 'Pasta com as planilhas que serão abertas e copiadas Application.Calculation = xlCalculationManual Application.ScreenUpdating = False For Each Planilha In FSO.GetFolder(Pasta).Files If InStr(1, Planilha, ".xls") = 0 Then GoTo PRÓXIMO Workbooks.Open (Planilha) OpenBook = ActiveWorkbook.Name 'Verificar se Branco "" 'Do While ActiveCell.Range("a2").Value <> "" For A = 1 To Sheets.Count Do While ActiveCell.Range("a2").Value <> "" Sheets(A).Select Sheets(A).Range("A2").Select 'código para copiar ActiveSheet.Range("a2:" & ActiveSheet.Range("b2"). _ End(xlDown).Address).Select Selection.Copy 'ativar o arquivo de onde os dados foram copiados Windows(ThisWorkbook.Name).Activate ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False 'Ativar depois ultima celula Range("A2").Select Set UltCel = Range("A1048576").End(xlUp) UltCel.Select ActiveCell.Offset(1, 0).Select Windows(ThisWorkbook.Name).ActivateNext ActiveSheet.Next.Select Loop Next PRÓXIMO: Next Application.ScreenUpdating = True MsgBox "Dados Copiados com Sucesso!", vbInformation, "Aviso" Application.Calculation = xlCalculationAutomatic End Sub

Ola pessoal Estou desenvolvendo uma macro e preciso abrir um arquivo do Excel localizar uma palavra procurando na horizontal e copiar os dados abaixo na vertical e fazer um loop para fazer isso em todos arquivos que esta em determinada pasta e colar na base principal. exemplo os dados estão da a2 ate a j2 preciso procurar uma determinada palavra nesse intervalo e copiar e colar em uma ordem que eu determinar. eu ate comecei a fazer porém a formula esta ficando muito grande e não sei se estou indo no caminho certo pois consegui escolher um intervalo e copiar os dados e não individualmente. ' Macro1 Macro ' ' Sub Abrir_Copiar_Colar() Range("a2").Select Dim FSO As Object Dim Pasta As String Dim Planilha As Object Dim OpenBook As String Set FSO = CreateObject("Scripting.FileSystemObject") Pasta = "C:\User\Desktop\FUNCIONARIO 2 RETAS - CONFERÊNCIA\" 'Pasta com as planilhas que serão abertas e copiadas Application.Calculation = xlCalculationManual Application.ScreenUpdating = False For Each Planilha In FSO.GetFolder(Pasta).Files If InStr(1, Planilha, ".xls") = 0 Then GoTo PRÓXIMO Workbooks.Open (Planilha) OpenBook = ActiveWorkbook.Name 'Seu código para copiar Range("A2:j2").Select Range(Selection, Selection.End(xlDown)).Select Range("A2:j21").Select Selection.Copy Windows(ThisWorkbook.Name).Activate 'Seu código para colar ActiveCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False Application.CutCopyMode = False Workbooks(OpenBook).Close False 'Ativar depois ultima celula Dim x As Integer x = ActiveSheet.UsedRange.Rows.Count ActiveCell.SpecialCells(xlLastCell).Select ActiveCell.EntireRow.Cells(1, 2).Offset(1, 0).Activate PRÓXIMO: Next