none
Copiar varias planilhas em um único arquivo RRS feed

  • Pergunta

  • Prezados,

    Boa Tarde, fiz um codigo para capturar uma sheets de uma determinada planilha, porem agora estou querendo pegar mais de uma e salvar todas em um unico arquivo, porem não estou conseguindo alguem poderia me ajudar?

    Private Sub btnRelatorio_Click()
    
        Dim chamarWb As Workbook
        Dim Destwb As Workbook
        Dim caminhoTemp As String
        Dim caminhoNome As String
        Dim sExtensao As String
        Dim nome As String
        Dim Plan As String
    
        
        Do Until Worksheets_Existe(Plan)
        Plan = InputBox("Informe o nome da planilha")
        If Not Worksheets_Existe(Plan) Then MsgBox Plan & " Não existe!", vbExclamation
        Loop
        
        Sheets(Plan).Select
        
        sExtensao = Mid(ThisWorkbook.FullName, (InStrRev(StringCheck:=ThisWorkbook.FullName, StringMatch:=".", Compare:=vbTextCompare)))
    
        MFIR = Replace(Range("c5").Value, ",", "")
        NOME_CLIENTE = Replace(Range("c4").Value, ",", "")
        
        nome = MFIR & "_" & correto(NOME_CLIENTE) & "_" & Format(Date, "dd-mm-yyyy") & ".xls"
     
        With Application
        
        .ScreenUpdating = False
        .EnableEvents = False
        
        End With
     
        Set chamarWb = ActiveWorkbook
     
        ActiveSheet.Copy
        Set Destwb = ActiveWorkbook
     
        caminhoTemp = ThisWorkbook.Path & "\"
      
        caminhoNome = nome
     
        With Destwb
            
        .SaveAs caminhoTemp & caminhoNome
          
        End With
     
    MsgBox "Seu arquivo se encontra no caminho " & caminhoTemp
     
        With Application
    
        End With
        
        Workbooks(nome).Close SaveChanges:=False
    
        Call Macro2
        
        Unload FormSalvar
    
        End Sub
    
    
    
    

    terça-feira, 26 de setembro de 2017 18:08

Respostas

  • Private Sub btnRelatorio_Click()
    
        Dim chamarWb As Workbook
        Dim Destwb As Workbook
        Dim caminhoTemp As String
        Dim caminhoNome As String
        Dim sExtensao As String
        Dim nome As String
        Dim Plan As String
    DIM I AS INTEGER
    'VAI PERCORRER TODAS AS PLANILHAS DA PASTA DE TRABALHO
    FOR I = 1 TO THISWORKBOOK.SHEETS.COUNT
    'Com exceção da planilha1
    'Se houver mais exceções, acrescente mais condições
    'Se não houver exceções, tire esta condição
    IF SHEETS(I).NAME <> "Planilha1" then
    
     
    
        Sheets(I).Select
        
        sExtensao = Mid(ThisWorkbook.FullName, (InStrRev(StringCheck:=ThisWorkbook.FullName, StringMatch:=".", Compare:=vbTextCompare)))
    
        MFIR = Replace(Range("c5").Value, ",", "")
        NOME_CLIENTE = Replace(Range("c4").Value, ",", "")
        
        nome = MFIR & "_" & correto(NOME_CLIENTE) & "_" & Format(Date, "dd-mm-yyyy") & ".xls"
     
        With Application
        
        .ScreenUpdating = False
        .EnableEvents = False
        
        End With
     
        Set chamarWb = ActiveWorkbook
     
        ActiveSheet.Copy
        Set Destwb = ActiveWorkbook
     
        caminhoTemp = ThisWorkbook.Path & "\"
      
        caminhoNome = nome
     
        With Destwb
            
        .SaveAs caminhoTemp & caminhoNome
          
        End With
     
    MsgBox "Seu arquivo se encontra no caminho " & caminhoTemp
     
        With Application
    
        End With
        
        Workbooks(nome).Close SaveChanges:=False
    
        Call Macro2
    end if
    
        NEXT I
    
        
        Unload FormSalvar
    End Sub
        


    Anderson Diniz





    • Sugerido como Resposta AndersonFDiniz2 quarta-feira, 27 de setembro de 2017 16:32
    • Marcado como Resposta WillGreco sexta-feira, 29 de setembro de 2017 02:25
    • Editado AndersonFDiniz2 sexta-feira, 29 de setembro de 2017 15:15
    quarta-feira, 27 de setembro de 2017 16:32