Importing text file into Excel but worksheet names are too long!

[ww8]

Hi,
I found a code online which allows me to select multiple text files, import each file's data onto its own worksheet and add a new master file of the appended data.
However it fails and after some research, I think it seems to a be a problem with the file names. The file names are very long and similar apart from the suffixed dates - therefore excel curtails the worksheet name after the 31st character and thinks the names are all the same.

Can you please help to get around this problem? It is not important to keep the worksheet names the same as the file names. Maybe the sheet names could just be the final 10 characters of the file name, or just "data 1", "data 2", "data 3" etc, in order for me to distinguish them.

Thanks for any help!


Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

sDelimiter = "|"

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If

x = 1
Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
x = x + 1

While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
End With
x = x + 1
Wend

ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

[snb]

'Somewhat' simpler.


Sub M_snb()
c00="G:\OF\"
c01=dir(c00 & "*.txt")

Do while c01<>""
sheets.add ,sheets(sheets.count),,c00 & c01
c01=dir
loop
End Sub