Combine Text Files into One Worksheet



This group is better than any "formal" training a gal could have. I've
learned a lot over the years from you and I have another questions that I
know you can help with. I need to combine multiple text files into one
worksheet. This should be fairly straight forward, however I just can't get
my arms around it. The text files (6 to 8 of them) need to have fixed length
columns, with all columns formatted as text to retain leading zeros. The
number of rows will most likely end up around 7000 for each text file.

The code I have works fine, with a large portion of the various subs coming
from this group. However, I don't think it needs to be as complex as it is.

A Sub called FormatFiles starts everything off. Sub ImportTextFile brings
in the text files and starts off other subs designed to combine the text
files into one worksheet. I'm just going to include the subs that actually
import the text files and combine them, to prevent this posting from being
too long. Can you help me trim this down while still having it function as

Sub ImportTextFile()

Dim File As Variant
Dim i As Long
Dim Book As Workbook

File = Application.GetOpenFilename(FileFilter:="Text files
(*.txt),*.txt", _
Title:="Select the files to import", MultiSelect:=True)

If TypeName(File) = "Boolean" Then Exit Sub

Application.ScreenUpdating = False

Set Book = Workbooks.Add(xlWorksheet)

For i = LBound(File) To UBound(File)
ProcessFile WhichFile:=CStr(File(i)), WhichBook:=Book
Next i

Application.DisplayAlerts = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Call CopyDataWithoutHeaders

End Sub
Sub ProcessFile(ByVal WhichFile As String, ByRef WhichBook As Workbook)

Dim WS As Worksheet
Dim ColumnInformation As Variant

ColumnInformation = Array(Array(0, 2), Array(4, 2), Array(10, 2),
Array(18, 2), _
Array(22, 2), Array(28, 2), Array(31, 2),
Array(36, 2), _
Array(42, 2), Array(51, 2), Array(54, 2))

Workbooks.OpenText Filename:=WhichFile, Origin:=xlWindows, StartRow:=1,
_ DataType:=xlFixedWidth, FieldInfo:=ColumnInformation


With ActiveSheet
.Copy After:=WhichBook.Sheets(WhichBook.Sheets.Count)
.Parent.Close SaveChanges:=False
End With

End Sub
Sub CopyDataWithoutHeaders()

Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set DestSh = ActiveWorkbook.Sheets(1)

StartRow = 1

For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then

Last = LastRow(DestSh)
shLast = LastRow(sh)

'If sh is not empty and if the last row >= StartRow copy the
If shLast > 0 And shLast >= StartRow Then

'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to
copy the
'values or want to copy everything look below example 1 on
this page
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If

Application.DisplayAlerts = False
Application.DisplayAlerts = True
End If



Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub
Function LastRow(sh As Worksheet)

On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"),
Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0

End Function


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question