Double InstrRev
Вы были просто еще InstrRev от решения.
Допустим, путь равен C:\Test\Input.txt.
После применения InstrRev с \ до Ret ...
x = Mid$(Ret, InStrRev(Ret, "\") + 1)
Вы получили это: Input.txt.
Теперь вам просто нужно применить InstrRev с . до x ...
FileName = Mid$(x, 1, InStrRev(x, ".") - 1)
чтобы получить это: Input.
А теперь вам нужно избавиться от x, то есть заменить x во втором выражении правой стороной первого выражения, чтобы получить это:
FileName = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)
Отсюда и решение :
Замените это ...
newWorksheet.Name = Mid$(Ret, InStrRev(Ret, "\") + 1)
... на
newWorksheet.Name = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)
... и все готово.
РЕДАКТИРОВАТЬ :
Ссылки
Workbook.SaveAs
XlFileFormat
Код
Option Explicit
Sub ImportTextFile()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' The following line is usually written immediately after the previous
' two lines.
On Error GoTo ProgramError
If Val(Application.Version) > 15 Then
If ActiveWorkbook.AutoSaveOn Then ActiveWorkbook.AutoSaveOn = False
End If
Dim Ret As Variant
Dim newWorksheet As Worksheet
Dim ws As Worksheet ' For Each Control Variable
Dim finishSuccess As Boolean
Dim fileName As String
Set newWorksheet = Sheets.Add(After:=Sheets("Konvertering"))
Ret = Application.GetOpenFilename("Text Files (*.txt), *.txt")
' Define fileName
fileName = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)
' Check if fileName exceeds 31 character limit:
If Len(fileName) > 31 Then GoTo FileNameTooLong
' Check if worksheet name exists.
For Each ws In ThisWorkbook.Worksheets
If ws.Name = fileName Then GoTo WorksheetNameTaken
Next ws
' Import Text File
If Ret = False Then GoTo SafeExit
With newWorksheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, Destination:=newWorksheet.Range("$A$1"))
.Name = "Sample"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
newWorksheet.Name = fileName
' Stop Excel complaining about losing the code.
Application.DisplayAlerts = False
' Assuming you want to save the file as .xlsx (without code).
ThisWorkbook.SaveAs fileName, xlOpenXMLWorkbook
' If you want to save as .xlsm (with code) then use
' 'xlOpenXMLWorkbookMacroEnabled' and remove the lines
' containing 'Application.DisplayAlerts ...'.
Application.DisplayAlerts = True
' If I'm mmissing the point, just outcomment the previous Application
' block and uncomment the following line and make changes appropriately.
' Thisworkbook.SaveAs fileName, xlOpenXMLWorkbookMacroEnabled
finishSuccess = True
SafeExit:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If finishSuccess Then
MsgBox "Finished successfully.", vbInformation, "Success"
' Close workbook without saving changes (False) ensuring that it
' always stays the same. Remove 'False' if I'm missing the point.
ThisWorkbook.Close False
End If
Exit Sub
WorksheetNameTaken:
MsgBox "There is already a worksheet named '" & fileName & "'.", _
vbInformation, "Custom Error Message"
GoTo SafeExit ' or change appropriately.
FileNameTooLong:
MsgBox "The file name '" & fileName & "' exceeds the 31 character limit.", _
vbInformation, "Custom Error Message"
GoTo SafeExit ' or change appropriately.
ProgramError:
' Handle Error (You can do better. A hint: 'vbYesNo'.)
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Custom Error Message"
On Error GoTo 0
GoTo SafeExit ' or change appropriately.
End Sub