Importar arquivo de Texto

2024 - VBA & Macros

Post Recente por xandyams 9 anos atrás

3 Posts

2 Usuários

0 Reactions

553 Visualizações

RSS

xandyams

(@xandyams)

Posts: 2

New Member

Topic starter

Olá bom dia! a todos

Tenho que sempre importar um arquivo de texto para o excel, para fazer algumas conferencias.
pois bem segue o cod abaixo:

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:UsersfiscalDesktopConferir RetornoRM160502.REM", Destination:= _
Range("$A$1"))

.Name = "RM160502"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(9, 9, 1, 1, 9, 1, 9, 9, 9, 9, 9, 9, 9, 9)
.TextFileFixedColumnWidths = Array(30, 77, 3, 9, 115, 36, 4, 28, 2, 7, 35, 21, 26)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub

o que estou precisando, são duas coisas:

Primeiro gostaria que abrisse uma caixa de dialogo(acho que o nome é esse), para que eu tenha a opção de escolher o arquivo a ser importado.
Obs o arquivo vai estar sempre na mesma pasta só ira mudar a sequencia Ex:RM160502.REM, RM160503.REM, RM160504.REM....etc.

Segundo, quando eu importo mais de um tenho a necessidade que eles ficam um abaixo do outro, o que eu não estou conseguindo com o código acima.
isso porque em " Destination:= _ Range("$A$1"))" tentei alterar aqui mas sem sucesso.

Obs> segue anexo um arquivo que uso para importar.

Alguém poderia por gentileza, dar uma ajudinha
Grato pela atenção!!!

Postado : 17/05/2016 6:44 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Bom dia!!

Veja se ajuda

Option Explicit

Sub AleVBA_20387()
'Data: 17/05/2016
'Autor: rushti
'Adaptado por: AleVBA (http://www.planilhando.com.br/forum/viewtopic.php?f=10&t=20387)
'Importar multimplos arquivos dentro de um diretório fixo (especifico)
    Dim nxt_row As Long
     'Altere o caminho
    Const strPath As String = "C:UsersAleVBADownloads"
    Dim strExtension As String
     'Para a atualização da tela
    Application.ScreenUpdating = False
    ChDir strPath
     'Altere a extenção do arquivo
    strExtension = Dir(strPath & "*.rem")
    Do While strExtension <> ""
         'Adiciona o nome do arquivo na linha seguinte
        Range("A65536").End(xlUp).Offset(1, 0).Value = strExtension
         'Prepara o conjunto de linhas de cada arquivo
        nxt_row = Range("A65536").End(xlUp).Offset(1, 0).Row
         
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & strPath & strExtension, Destination:=Range("$A$" & nxt_row))
            .Name = strExtension
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlFixedWidth
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(9, 9, 1, 1, 9, 1, 9, 9, 9, 9, 9, 9, 9, 9)
            .TextFileFixedColumnWidths = Array(30, 77, 3, 9, 115, 36, 4, 28, 2, 7, 35, 21, 26)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
         
        strExtension = Dir
    Loop

    Application.ScreenUpdating = True
End Sub

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 17/05/2016 8:07 am