VBA Code


Sub Extract_Text_Files()
' Written by Barrie Davidson

Dim Rollup_File_Name As String
Dim File_Names As Variant
Dim File_count As Integer
Dim Active_File_Name As String
Dim Counter As Integer
Dim File_Save_Name As Variant
Dim Characters As Integer
    
    
    File_Names = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    File_count = UBound(File_Names)
    Counter = 1
    Do Until Counter > File_count
        Workbooks.Add
        Rollup_File_Name = ActiveWorkbook.Name
        Active_File_Name = File_Names(Counter)
        Workbooks.OpenText FileName:=Active_File_Name, Origin:=xlWindows _
            , StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), _
            Array(20, 1), Array(40, 1), Array(60, 1))
        Active_File_Name = ActiveWorkbook.Name
        Range("A1:A10").Copy ' You need to change this to the correct copy range
        Windows(Rollup_File_Name).Activate
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Windows(Active_File_Name).Activate
        File_Save_Name = InStr(1, Active_File_Name, ".txt", 1) - 1
        File_Save_Name = Mid(Active_File_Name, 1, File_Save_Name) & ".xls"
        Windows(Rollup_File_Name).Activate
        ActiveWorkbook.SaveAs FileName:=File_Save_Name, FileFormat:= _
            xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
            , CreateBackup:=False
        File_Names(Counter) = ActiveWorkbook.FullName
        ActiveWindow.Close
        Windows(Active_File_Name).Activate
        ActiveWindow.Close
        Counter = Counter + 1
    Loop
    Counter = 1
    Do Until Counter > File_count
        Workbooks.Open FileName:=File_Names(Counter)
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
        Counter = Counter + 1
        ActiveWindow.Close
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    

End Sub