Open Text Files/Format/Save as .xls for multiple files.

[Ray]

This may be complicated so please bear with me. I have 68 .txt files that I
need to open in excel and delete some header information. Then I need to
save the file as an .xls. I have managed to develop the code to do one file
but I would like to create a Loop of sorts to do the rest without having to
write the code for each file. For one file the code looks like:

ChDir "D:\Biolum\Survey Data\600708\Cast001"
Workbooks.OpenText Filename:= _
"D:\Biolum\Survey Data\600708\Cast001\60070801.txt", Origin:=437,
StartRow _
:=30, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False,
Comma:=False _
, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2,
1), Array _
(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8,
1), Array(9, 1), Array( _
10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1)),
TrailingMinusNumbers _
:=True
With ActiveWindow
.Width = 791.25
.Height = 599.25
End With
ActiveWindow.SmallScroll Down:=-18
Rows("1:1").Select
Selection.Insert Shift:=x1Down
Range("B1").Select
ActiveCell.Formula = "RecNbr"
Range("C1").Select
ActiveCell.Formula = "Time"
Range("D1").Select
ActiveCell.Formula = "Depth"
Range("E1").Select
ActiveCell.Formula = "BIO cps"
Range("F1").Select
ActiveCell.Formula = "NDx"
Range("G1").Select
ActiveCell.Formula = "Tmp"
Range("H1").Select
ActiveCell.Formula = "CHL"
Range("I1").Select
ActiveCell.Formula = "Cnd"
Range("J1").Select
ActiveCell.Formula = "Trans"
Range("K1").Select
ActiveCell.Formula = "LSS"
Range("L1").Select
ActiveCell.Formula = "Batt"
Range("M1").Select
ActiveCell.Formula = "Lat"
Range("N1").Select
ActiveCell.Formula = "Long"
ActiveWorkbook.SaveAs Filename:= _
"D:\Biolum\Survey Data\600708\60070801.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close


What will change for each file is the Cast number (Cast001, Cast002, etc)
and the file name (60070801.xls, 60070802.xls, etx).

Any help will be greatly appreciated.

Cheers,
-Ray

And while I'm at it, I plan to combine each file into a master workbook
with each cast on it's own tab. Any help with that would be great as well.

 

[Dave Peterson]

Untested, uncompiled. And you'll have to merge your existing code into this
shell:

Option Explicit
Sub aa()
Dim iCtr As Long
Dim TestStr As String
Dim myPath As String
Dim myFileName As String

For iCtr = 1 To 68
myPath = "D:\Biolum\Survey Data\600708\Cast0" _
& Format(iCtr, "00") & "\"
myFileName = "600708" & Format(iCtr, "00")

TestStr = ""
On Error Resume Next
TestStr = Dir(myPath & myFileName & ".txt")
On Error GoTo 0

If TestStr = "" Then
MsgBox mypath & myFileName & ".txt" & " was not found!"
Exit Sub 'if you want to stop the rest of the processing
End If

Workbooks.OpenText _
Filename:=myPath & myFileName & ".txt", _
rest of that opentext line

'your code that does all the work

Application.DisplayAlerts = False 'overwrite existing file??
ActiveWorkbook.SaveAs _
Filename:=myPath & myFileName & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close

Next iCtr

End Sub

 

[Joel]

See if this works.

Sub combine()

FolderName = "D:\Biolum\Survey Data" '\600708\Cast001
ChDrive "D"
ChDir FolderName

Set fs = CreateObject("Scripting.FileSystemObject")
Set Folder = _
fs.GetFolder(FolderName)

If Folder.subfolders.Count > 0 Then
For Each Sf In Folder.subfolders
With ThisWorkbook
'Create New Sheet
Set NewSht = .Sheets.Add( _
after:=.Sheets(Sheets.Count))
NewSht.Name = Sf.Name

With NewSht
.Range("B1") = "RecNbr"
.Range("C1") = "Time"
.Range("D1") = "Depth"
.Range("E1") = "BIO cps"
.Range("F1") = "NDx"
.Range("G1") = "RTmp"
.Range("H1") = "CHL"
.Range("I1") = "Cnd"
.Range("J1") = "Trans"
.Range("K1") = "LSS"
.Range("L1") = "Batt"
.Range("M1") = "Lat"
.Range("N1") = "Long"

For Each Myfile In Folder.Files
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

With .QueryTables.Add( _
Connection:="TEXT;" & Myfile.Path, _
Destination:=.Range("A" & NewRow))

.Name = Myfile.Path
.TextFileParseType = xlDelimited
.TextFileTextQualifier = _
xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileSpaceDelimiter = True
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False

End With
Next Myfile
End With
End With
Next Sf

ThisWorkbook.Save
End If

End Sub

 

[Joel]

By the way, my code is tested and just puts all the data into the workbook
where the macro is located. I didn't bother making seperate files for each
Cast. The code starts at the root folder and goes into each folder and get
all the files.

 

[Ray]

Thanks Dave. You saved me a great deal of time.

Untested, uncompiled. And you'll have to merge your existing code into this
shell:

Option Explicit
Sub aa()
Dim iCtr As Long
Dim TestStr As String
Dim myPath As String
Dim myFileName As String

For iCtr = 1 To 68
myPath = "D:\Biolum\Survey Data\600708\Cast0" _
& Format(iCtr, "00") & "\"
myFileName = "600708" & Format(iCtr, "00")

TestStr = ""
On Error Resume Next
TestStr = Dir(myPath & myFileName & ".txt")
On Error GoTo 0

If TestStr = "" Then
MsgBox mypath & myFileName & ".txt" & " was not found!"
Exit Sub 'if you want to stop the rest of the processing
End If

Workbooks.OpenText _
Filename:=myPath & myFileName & ".txt", _
rest of that opentext line

'your code that does all the work

Application.DisplayAlerts = False 'overwrite existing file??
ActiveWorkbook.SaveAs _
Filename:=myPath & myFileName & ".xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close

Next iCtr

End Sub

 

[Ray]

Joel,
Thanks for the reply. I did try your code but I got an error at
Set NewSht = .Sheets.Add( _
after:=.Sheets(Sheets.Count))

 

[Patrick Molloy]

looks ok. is the newsht variable dimensioned properly?

also
:=.Sheets(Sheets.Count))
should be
:=.Sheets(.Sheets.Count)) ' dot before Sheets ni both cases



Dim NewSht As Worksheet

Set NewSht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))

 

[Joel]

I'm suprised that the error occured here. Was it a compile error or a run
time error? The code is trying to add a worksheet to the workbook where the
macro is located. There is no limit to the number of sheets that can be
added. I made a simple macro to check the line and it works fine for me??????

Sub test1()

With ThisWorkbook
Set NewSht = .Sheets.Add( _
after:=.Sheets(Sheets.Count))

End With
End Sub


Maybe the workbook is protected where you are runing the macro.

 

[Ray]

FYI. the following is the code I used to combine all the individual casts
into one master file. Thanks again for your help.

Sub Combine_Multiple_Files()
'
' This macor will combine multiple files into one master file.
' Macro recorded by Raymond J Pluhar
'

'
Workbooks.Open Filename:= _
"D:\Biolum\600708_Master.xls"

Dim iCtr As Long
Dim TestStr As String
Dim myPath As String
Dim myFileName As String

For iCtr = 1 To 68
myPath = "D:\Biolum\Survey Data\600708\Cast0" _
& Format(iCtr, "00") & "\"
myFileName = "600708" & Format(iCtr, "00")

TestStr = ""
On Error Resume Next
TestStr = Dir(myPath & myFileName & ".xls")
On Error GoTo 0

If TestStr = "" Then
MsgBox myPath & myFileName & ".xls" & " was not found!"
Exit Sub 'if you want to stop the rest of the processing
End If


Workbooks.Open Filename:=myPath & myFileName & ".xls", _
Origin:=xlWindows
Sheets(myFileName).Select
Sheets(myFileName).Copy After:=Workbooks("600708_Master.xls").Sheets(iCtr)
ActiveWorkbook.Save
Windows(myFileName & ".xls").Activate
ActiveWorkbook.Close


Next iCtr

End Sub

 

[Ray]

I put the module in the same workbook that the data gets pulled into. The
macro creates the right number of tabs with the proper headings. however, it
does not pull the data into the tabs. Meaning that I have 68 tabs with
header info, but no data.