Hello
what I am tryng to do is import in excel a number of files (a file per sheet).
I would like to be able to specify for the open file command the "OtherChar" option, say "|"
The code below works fine except for this option (see red lines below) which I was not able to figure it out.
Please help
Katto01
what I am tryng to do is import in excel a number of files (a file per sheet).
I would like to be able to specify for the open file command the "OtherChar" option, say "|"
The code below works fine except for this option (see red lines below) which I was not able to figure it out.
Please help
Katto01
Code:
Sub ImportAllFilesInDirectory()
Dim SelectedItem As Variant
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim strPath As String, ext As String
Dim strFile As String
fd.AllowMultiSelect = False
If fd.Show = False Then Exit Sub
strPath = fd.SelectedItems(1)
mePath = FunctionGetFilepath(strPath)
strFile = FunctionGetFileName(strPath)
ext = FunctionGetFileExt(strPath)
strFile = UCase(Dir(mePath & "*" & ext))
Do While strFile <> ""
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath, _
Destination:=.Range("A1"))
.Parent.Name = Replace(strFile, ext, "")
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End With
strFile = Dir
Loop
End Sub
Sub ImportSelectedFiles()
'Program will ask for how many files to import.
'You will be prompted to browse to and select files to import.
Dim strPath As String
Dim strFile As String
Dim N As Integer, L As Integer
Dim Dupe As String
Dim SelectedItem As Variant
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
N = Application.InputBox _
(Prompt:="Enter Number of Files To Import ? ", _
Default:=1, Type:=1)
For L = 1 To N
Rechoose:
If fd.Show = False Then Exit Sub
strPath = fd.SelectedItems(1)
strFile = FunctionGetFileName(strPath)
ext = FunctionGetFileExt(strPath)
If InStr(1, Dupe, strPath) Then
MsgBox "Duplicate File Name. Reselect a file"
GoTo Rechoose
End If
Dupe = Dupe & strPath
T$ = "S" + LTrim(RTrim(Chr$(L + 48)))
S$ = Replace(strFile, ext, T$)
S$ = Mid(S$, 1, 28) + LTrim(RTrim(Chr$(L + 48)))
With ActiveWorkbook.Worksheets.Add
With .QueryTables.Add(Connection:="TEXT;" & strPath, _
Destination:=.Range("A1"))
.Parent.Name = S$
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
[COLOR="Red"] '.TextFileOther = True
'.TextFileOtherChar = "|"[/COLOR]
.Refresh BackgroundQuery:=True
End With
End With
Next L
End Sub
Function FunctionGetFileName(FullPath As String)
Dim StrFind As String
Do Until Left(StrFind, 1) = "\"
iCount = iCount + 1
StrFind = Right(FullPath, iCount)
If iCount = Len(FullPath) Then Exit Do
Loop
FunctionGetFileName = Right(StrFind, Len(StrFind) - 1)
End Function
Function FunctionGetFileExt(FullPath As String)
Dim StrFind As String
Do Until Left(StrFind, 1) = "."
iCount = iCount + 1
StrFind = Right(FullPath, iCount)
If iCount = Len(FullPath) Then Exit Do
Loop
FunctionGetFileExt = Right(StrFind, Len(StrFind))
End Function
Function FunctionGetFilepath(FullPath As String)
Dim StrFind As String
Do Until Left(StrFind, 1) = "\"
iCount = iCount + 1
StrFind = Right(FullPath, iCount)
If iCount = Len(FullPath) Then Exit Do
Loop
FunctionGetFilepath = Mid(FullPath, 1, Len(FullPath) - Len(StrFind) + 1)
End Function
