V
VBA_Newbie79
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
needed?
=======================
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
Book.Sheets(1).Delete
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
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
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
CopyRng
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
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
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
=======================
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
needed?
=======================
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
Book.Sheets(1).Delete
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
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
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
CopyRng
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
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
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
=======================