Opening all text files and saving as .xls

Try setting your default drive to your working drive and the following admend below.

Sub openfiles()

'Get current Dir
OldDir = CurDir
'Now change default Dir
ChDir "A:\"

NextFile = Dir("A:\*.*", vbNormal)
Do While NextFile <> ""
Workbooks.OpenText FileName:=NextFile, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2 _
), Array(2, 2), Array(3, 2), Array(4, 1), Array(5, 1), Array(6, 1))

newname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
ActiveWorkbook.SaveAs FileName:="C:\" & newname & ".xls"
NextFile = Dir
Loop

'Restore back to old directory
ChDir OldDir
End Sub

HTH

Ivan

Ben
Sorry......tested now try this ???

Dim x As Integer
Dim temp
Dim i As Integer
Dim Drive As String
Dim Filename 'Must be a variant !!
Dim ChFiles() As String
Dim FFiles As Integer
Dim WB As Integer

Sub Version2()
'---------------------
Drive = "A:\" 'Change this for another drive
'----------------------

With Application.FileSearch
.NewSearch
.LookIn = Drive
.SearchSubFolders = False
.Filename = "*.txt"
.MatchTextExactly = True
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
ReDim ChFiles(.FoundFiles.Count)
For i = 1 To .FoundFiles.Count
'Get Filename only
x = 1
While InStr(x, .FoundFiles(i), "\") <> 0
temp = InStr(x, .FoundFiles(i), "\")
x = x + 1
Wend
ChFiles(i) = Right(.FoundFiles(i), Len(.FoundFiles(i)) - x + 1)
Next
End If

If .FoundFiles.Count = 0 Then MsgBox "No Text files in " & Drive: End
End With
'---------------------------------------------------------------------
On Error GoTo ErrH
Application.ScreenUpdating = False

For WB = 1 To UBound(ChFiles())
Workbooks.OpenText Drive & ChFiles(WB), Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2), _
Array(2, 2), Array(3, 2), Array(4, 1), Array(5, 1), Array(6, 1))

ActiveWorkbook.SaveAs Filename:="C:\" & Left(ChFiles(WB), Len(ChFiles(WB)) - 3) & "xls"
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
MsgBox "Completed!"
Exit Sub
ErrH:
If Err.Number <> 1004 Then
MsgBox Err.Number & " :=" & Err.Description
Else
Resume Next
End If

End Sub

Ivan

HTH Ivan

Thanks Ivan, but Excel still doesn't like NextFile = Dir("A:\*.*", vbNormal). It will open the files some of the time. If I change NextFile to ("A:\*.*") then the first file always opens but, of course, it tries to open the same file over & over. Any more thoughts?

Thanks Ivan. I tried that. VB opens the first file but won't open the rest.

Thanks Ivan, but now I get a "The file could not be accessed" error.

Ben, not tested but put this in

ChDir "A:\" after ActiveWorkbook.Close

Ivan

Need Help Again with Dates (CELIA, Please HELP!)

Need Help Again with Dates (CELIA, Please HELP!)

Hi, as i stated before, i´m a Judge in Venezuela who is confronting problems creating a Worksheet to calculate times of conviction.
Celia has helped Before, but as i was creating the Worksheet i discovered that then i had to introduce the time of the imprinsonment (?) as follows:
Years Months Days Hours Minutes
1 5 22 2 30

Then i have to add that much time to a "given" date as 22/8/00
Also, i have to take 2/3, 1/3, 1/2, 1/4 to the initial amount of years, months days, hours and minutes and add it too to the second date, that is the day the convict initiates his conviction.
Problems is that this is not all. I also have to calculate the amount of time elapsed since the initial detention of the convict to the day of today, and that date becomes the "given" date i mentioned before...
ARGH!

YOU COULD TRY SOMETHING DIFF, Option Explicit Dim i As Integer Dim Drive As String Dim Filename 'Must be a variant !! Dim ChFiles() As String Dim FFiles As Integer Dim WB As Integer Sub Version1() '--------------------- Drive = "A:\" '---------------------- With Application.FileSearch .NewSearch .LookIn = Drive .SearchSubFolders = False .Filename = "*.txt" .MatchTextExactly = True .MatchAllWordForms = True .FileType = msoFileTypeAllFiles If .Execute() > 0 Then ReDim ChFiles(.FoundFiles.Count) For i = 1 To .FoundFiles.Count ChFiles(i) = .FoundFiles(i) Next End If If .FoundFiles.Count = 0 Then MsgBox "No Text files in " & Drive: End End With '--------------------------------------------------------------------- On Error GoTo ErrH Application.ScreenUpdating = False For WB = 1 To UBound(ChFiles()) Workbooks.OpenText ChFiles(WB), Origin:=xlWindows, _ StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _ , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2), _ Array(2, 2), Array(3, 2), Array(4, 1), Array(5, 1), Array(6, 1)) ActiveWorkbook.SaveAs Filename:=Left(ChFiles(WB), Len(ChFiles(WB)) - 3) & "xls" ActiveWorkbook.Saved = True ActiveWorkbook.Close Next Application.ScreenUpdating = True MsgBox "Completed!" Exit Sub ErrH: If Err.Number <> 1004 Then MsgBox Err.Number & " :=" & Err.Description Else Resume Next End If End Sub NB: Not tested ! Ivan

Thanks Ivan, it's opening all text files on the floppy just great. Now, how do I get it to save files to the C:\ drive?

HTH Ivan

Ivan, I seem to have a glitch in vb. I can run some subs in one module but not in others. For example, I can run x = GetFileList("A:\") in one module but get the error "Sub or function not defined in another." I reinstalled Excel but no change.

Ignore the "alxo" message

Sorry, the function was missing from the other project.

YOU COULD TRY SOMETHING DIFF, Option Explicit Dim i As Integer : Dim Drive As String : Dim Filename 'Must be a variant !! : Dim ChFiles() As String : Dim FFiles As Integer : Dim WB As Integer Sub Version1() : '--------------------- : Drive = "A:\" : '---------------------- With Application.FileSearch : .NewSearch : .LookIn = Drive : .SearchSubFolders = False : .Filename = "*.txt" : .MatchTextExactly = True : .MatchAllWordForms = True : .FileType = msoFileTypeAllFiles : If .Execute() > 0 Then : ReDim ChFiles(.FoundFiles.Count) : For i = 1 To .FoundFiles.Count : ChFiles(i) = .FoundFiles(i) : Next : End If : If .FoundFiles.Count = 0 Then MsgBox "No Text files in " & Drive: End : End With : '--------------------------------------------------------------------- : On Error GoTo ErrH : Application.ScreenUpdating = False For WB = 1 To UBound(ChFiles()) : Workbooks.OpenText ChFiles(WB), Origin:=xlWindows, _ : StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ : ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _ : , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2), _ : Array(2, 2), Array(3, 2), Array(4, 1), Array(5, 1), Array(6, 1)) ActiveWorkbook.SaveAs Filename:=Left(ChFiles(WB), Len(ChFiles(WB)) - 3) & "xls" : ActiveWorkbook.Saved = True : ActiveWorkbook.Close : Next : Application.ScreenUpdating = True : MsgBox "Completed!" : Exit Sub : ErrH

Woops, sorry forgot about that, in that it is
saving to the A:\

Just change;
ActiveWorkbook.SaveAs Filename:=Left(ChFiles(WB), Len(ChFiles(WB)) - 3) & "xls"

TO;

ActiveWorkbook.SaveAs Filename:= "C:\" & Left(ChFiles(WB), Len(ChFiles(WB)) - 3) & "xls"

Ivan

Thanks Ivan, but Excel still doesn't like NextFile = Dir("A:\*.*", vbNormal). It will open the files some of the time. If I change NextFile to ("A:\*.*") then the first file always opens but, of course, it tries to open the same file over & over. Any more thoughts?

YOU COULD TRY SOMETHING DIFF,

Option Explicit

Dim i As Integer
Dim Drive As String
Dim Filename 'Must be a variant !!
Dim ChFiles() As String
Dim FFiles As Integer
Dim WB As Integer

Sub Version1()
'---------------------
Drive = "A:\"
'----------------------

With Application.FileSearch
.NewSearch
.LookIn = Drive
.SearchSubFolders = False
.Filename = "*.txt"
.MatchTextExactly = True
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
ReDim ChFiles(.FoundFiles.Count)
For i = 1 To .FoundFiles.Count
ChFiles(i) = .FoundFiles(i)
Next
End If
If .FoundFiles.Count = 0 Then MsgBox "No Text files in " & Drive: End
End With
'---------------------------------------------------------------------
On Error GoTo ErrH
Application.ScreenUpdating = False

For WB = 1 To UBound(ChFiles())
Workbooks.OpenText ChFiles(WB), Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 2), _
Array(2, 2), Array(3, 2), Array(4, 1), Array(5, 1), Array(6, 1))

ActiveWorkbook.SaveAs Filename:=Left(ChFiles(WB), Len(ChFiles(WB)) - 3) & "xls"
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
MsgBox "Completed!"
Exit Sub
ErrH:
If Err.Number <> 1004 Then
MsgBox Err.Number & " :=" & Err.Description
Else
Resume Next
End If

End Sub

NB: Not tested !

Ivan

YOU COULD TRY SOMETHING DIFF, : Option Explicit : Dim i As Integer

Thanks Ivan, but now I get a "The file could not be accessed" error.