I'm running a Macro on Excel to import multiple .txt files and with a filter set to the filename, so it acts like a wildcard. Every file has the same layout, it's Semicolon delimited, has a header and 11 colunms.
The macro works fine, except its importing the files "Side by Side" or "horizontally". Instead of import the next file "under" (like, the first file goes up to the row 10, then next one start importing at row 11), it start importing in the next colunm (the first goes up the colunm "K", the next one start importing on colunm L).
How can I fix it? Heres the code:
Sub Abrir_PORT()
Dim Caminho As String
Caminho = Sheets("DADOS").Cells(5, 5).Value
Sheets("PORT").Select
Dim FS
Set FS = CreateObject("Scripting.FileSystemObject")
Dim Filter As String: Filter = "ATENTO_TLMKT_REC*.txt"
Dim dirTmp As String
If FS.FolderExists(Caminho) Then
dirTmp = Dir(Caminho & "\" & Filter)
Do While Len(dirTmp) > 0
Call Importar_PORT(Caminho & "\" & dirTmp, _
Left(dirTmp, InStrRev(dirTmp, ".") - 1))
dirTmp = Dir
Loop
End If
End Sub
Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & iFullFilePath, _
Destination:=Range("$A$1"))
.Name = iFileNameWithoutExtension
.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 = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
iRow = 2
Do While Sheets("PORT").Cells(iRow, 1) <> ""
If Cells(iRow, 2) = IsNumber Then
Else
Rows(iRow).Select
Selection.EntireRow.Delete
iRow = iRow - 1
contagem = contagem + 1
End If
iRow = iRow + 1
Loop
End With
End Sub
Adding a check if Range("A1")
is empty so it starts at A1
if A1
is empty...
Tested and working:
Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)
Dim lngStartRow As Long
With ActiveSheet
If .Range("A1") = "" Then
lngStartRow = 1
Else
lngStartRow = .Range("A" & .Rows.Count).End(xlUp).row + 1
End If
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & iFullFilePath, _
Destination:=Range("$A$" & lngStartRow))
I haven't tested but it seems like replacing :
Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & iFullFilePath, _
Destination:=Range("$A$1"))
with :
Sub Importar_PORT(iFullFilePath As String, iFileNameWithoutExtension)
afterLast = Cells(Rows.Count, 1).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & iFullFilePath, _
Destination:=Range("$A$" & afterLast))
would work fine.
来源:https://stackoverflow.com/questions/21608393/import-multiple-text-files-in-the-same-excel-sheet