Ir ao conteúdo
  • Cadastre-se
Jéssica De Moura Lima

Excel Importar dados de arquivos externos

Recommended Posts

Olá!

 

Gostaria de importar dados de um arquivo externo, mas o meu código não está funcionando.

 

 

Sub Importar()

 

Dim Abrir As String
Dim Importarwb As Workbook
Dim Importarguia As Worksheet

 

Abrir = Application.GetOpenFilename( _
FileFilter:="Arquivo do Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Escolha o arquivo a ser importado")

 

Set Importarwb = Application.Workbooks.Open( _
Filename:=Abrir, Password:="123")

 

Set Importarguia = Importarwb.Worksheets(1)

 

Application.ScreenUpdating = False

 

'Desbloquear guia e pasta de trabalho
ThisWorkbook.Unprotect ("123")
ActiveSheet.Unprotect ("123")

 

'Copiar dados
Importarguia.Copy

 

'Limpar guia "Relatório" e colar dados
Worksheets("Relatório").Visible = True

With Worksheets("Relatório")
    .Visible = True
    .Range(.Cells(1, 1), .Cells(10000, 90)).ClearContents
    .Paste
    .Visible = False
    
End With

 

'Fechar arquivo externo
Importarwb.Close

 

'Bloquear guia e pasta de trabalho
ThisWorkbook.Protect Password:="123", Structure:=True, Windows:=False

 

Sheets("Base de Contratos").Protect Password:="123", _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True, _
    UserInterfaceOnly:=True, _
    AllowFormattingCells:=False, _
    AllowFormattingColumns:=False, _
    AllowFormattingRows:=True, _

    AllowInsertingColumns:=False, _
    AllowInsertingRows:=True, _
    AllowInsertingHyperlinks:=False, _
    AllowDeletingColumns:=False, _
    AllowDeletingRows:=True, _
    AllowSorting:=False, _
    AllowFiltering:=True, _
    AllowUsingPivotTables:=False

 

Application.ScreenUpdating = True

 

MsgBox "Relatório importado com sucesso!"

 

End Sub

 

Alguém poderia me ajudar?

Compartilhar este post


Link para o post
Compartilhar em outros sites

@Jéssica De Moura Lima fiz as alterações,mas não tive como testar,

 

Veja se é isso e de retorno por favor.

.

Sub Importar()
    Dim Abrir As String
    Dim Importarwb As Workbook
    Dim Importarguia As Worksheet
    Dim xlObj As Object
    
    On Error GoTo trataErro
    
    Set xlObj = CreateObject("excel.application")
    
    
    Abrir = Application.GetOpenFilename( _
    FileFilter:="Arquivo do Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Escolha o arquivo a ser importado")
    
    Set Importarwb = xlObj.Workbooks.Open( _
    Filename:=Abrir, Password:="123")
    
    Set Importarguia = Importarwb.Worksheets(1)
    
    Application.ScreenUpdating = False
    
    'Desbloquear guia e pasta de trabalho
    ThisWorkbook.Unprotect ("123")
    ActiveSheet.Unprotect ("123")
    
    'Copiar dados
    Importarguia.UsedRange.Copy
    
    'Limpar guia "Relatório" e colar dados
    ThisWorkbook.Worksheets("Relatório").Visible = True
    
    With Worksheets("Relatório")
        .Activate
        .Range(.Cells(1, 1), .Cells(10000, 90)).ClearContents
        .Cells(1, 1).Select
        .Paste
        .Visible = False
    End With
    
    Importarwb.Application.CutCopyMode = False
    
    
    'Fechar arquivo externo
    If Not Importarwb Is Nothing Then
        Importarwb.Close False
        Set Importarwb = Nothing
        Set xlObj = Nothing
    End If
    
    'Bloquear guia e pasta de trabalho
    ThisWorkbook.Protect Password:="123", Structure:=True, Windows:=False
    
    Sheets("Base de Contratos").Protect Password:="123", _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True, _
    UserInterfaceOnly:=True, _
    AllowFormattingCells:=False, _
    AllowFormattingColumns:=False, _
    AllowFormattingRows:=True, _
    AllowInsertingColumns:=False, _
    AllowInsertingRows:=True, _
    AllowInsertingHyperlinks:=False, _
    AllowDeletingColumns:=False, _
    AllowDeletingRows:=True, _
    AllowSorting:=False, _
    AllowFiltering:=True, _
    AllowUsingPivotTables:=False
    
trataErro:
    Application.ScreenUpdating = True
    If Not Importarwb Is Nothing Then
        Importarwb.Close False
        Set Importarwb = Nothing
        Set xlObj = Nothing
    End If
    
    
    MsgBox "Relatório importado com sucesso!"
    
End Sub

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×