Importing Multiple Text Files using VB

  • Thread starter Thread starter Robert
  • Start date Start date
R

Robert

Hiya
I have found a very useful macro except that there are a couple of
changes needed for it to suit my purpose.Being "vb" challenged I can't
seem to get it to work fthe way I want it.
The macro will import text files from a specified directory however it
places the text file name on top of each column as well as the data. I
need it to enter the information row by row with the text file name at
the start of each row. The data would be entered into a single cell
where I have formulas to extract the information that I need. Please
help.

Sub Consolidate()
With Application.FileSearch
.NewSearch
'Change this to your directory
.LookIn = "D:\Work\Text Import"
.SearchSubFolders = False
.Filename = "*.txt"
If .Execute() > 0 Then
Set Basebook = Workbooks.Add
For i = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(i), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited,
TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True,
Semicolon:=False, _
Comma:=True, Space:=False, Other:=False,
FieldInfo:=Array(1, 1)
Range("A1").CurrentRegion.Copy _
Basebook.Worksheets(1).Range("IV2").End(xlToLeft).Offset(0,
1)

Basebook.Worksheets(1).Range("1:1").SpecialCells(xlCellTypeBlanks).Value
=
ActiveWorkbook.Name
ActiveWorkbook.Close False
Next i
Basebook.Worksheets(1).Range("A:A").Delete
Basebook.SaveAs Application.GetSaveAsFilename("Consolidated
file.xls")
End If
End With
End Sub

The original thread is here:
http://groups.google.com/groups?hl=en&lr=&c2coff=1&th=eb1ff044745c5d4f&rnum=1

Bob
 
One way:

Option Explicit

Sub Consolidate()

Dim BaseWks As Worksheet
Dim nextWks As Worksheet
Dim iCtr As Long
Dim rngToCopy As Range
Dim DestCell As Range

With Application.FileSearch
.NewSearch
'Change this to your directory
.LookIn = "D:\Work\Text Import"
.SearchSubFolders = False
.Filename = "*.txt"
If .Execute() > 0 Then
Set BaseWks = Workbooks.Add(1).Worksheets(1)
Set DestCell = BaseWks.Range("b1")
For iCtr = 1 To .FoundFiles.Count
Workbooks.OpenText Filename:=.FoundFiles(iCtr), _
Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Tab:=True, Semicolon:=False, Comma:=True, Space:=False, _
Other:=False, FieldInfo:=Array(1, 1)
Set nextWks = ActiveSheet
With nextWks
Set rngToCopy = .Range("a1").CurrentRegion
DestCell.Resize(rngToCopy.Rows.Count, _
rngToCopy.Columns.Count).Value _
= rngToCopy.Value
DestCell.Offset(0, -1).Resize(rngToCopy.Rows.Count).Value _
= .Parent.Name
End With
Set DestCell = DestCell.Offset(rngToCopy.Rows.Count)
nextWks.Parent.Close savechanges:=False
Next iCtr
MsgBox "Don't forget to save this new workbook!"
End If
End With
End Sub
 
Back
Top