Temat: [VBA] Importowanie wielu plików txt

Witam,

Ma ktoś pomysł jak zmodyfikować poniższe makro tak, żeby pliki były importowane do jednej kolumny jeden plik pod drugim (w obecnej wersji importuje każdy plik do osobnej kolumny)

ub Import()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim DestCell As Range
Dim NewWks As Worksheet
Dim wks As Worksheet

'change to point at the folder to check
myPath = "C:\STYCZEŃ"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = ""
On Error Resume Next
myFile = Dir(myPath & "*.txt")
On Error GoTo 0
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

Application.ScreenUpdating = False

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then

Set NewWks = Workbooks.Add(1).Worksheets(1)
Set DestCell = NewWks.Range("a1")

For fCtr = LBound(myNames) To UBound(myNames)

Application.StatusBar _
= "Processing: " & myNames(fCtr) & " at: " & Now

Workbooks.OpenText Filename:=myPath & myNames(fCtr), _
Origin:=437, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, _
Space:=False, Other:=False, FieldInfo:=Array(1, 2)

Set wks = ActiveSheet
DestCell.Value = "'" & myNames(fCtr)
wks.Columns(1).Copy _
Destination:=DestCell.Offset(0, 1)
wks.Parent.Close savechanges:=False

Set DestCell = DestCell.Offset(0, 1)

Next fCtr
End If

With Application
.ScreenUpdating = True
.StatusBar = False
End With

End Sub

Dzięki za wszelkie wskazówki

Temat: [VBA] Importowanie wielu plików txt

Zmień parametr Offet na wyznaczenie końca zakresu

DestCell.Offset(0, 1)

Przeczytaj poniższy opis bo jest do tego gotowy dodatek:


Ten post został edytowany przez Autora dnia 18.09.14 o godzinie 16:04