Home » excel » excel – Sheet name equal to name of input text file

excel – Sheet name equal to name of input text file

Posted by: admin May 14, 2020 Leave a comment

Questions:

Updated.

I have the following code:

Sub ImportTextFile()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Val(Application.Version) > 15 Then
If ActiveWorkbook.AutoSaveOn Then ActiveWorkbook.AutoSaveOn = False
End If
Dim Ret
Dim newWorksheet As Worksheet
Set newWorksheet = Sheets.Add(After:=Sheets("Konvertering"))
Ret = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If Ret <> False Then
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 = Mid$(Ret, InStrRev(Ret, "\") + 1)
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

It imports a textfile to a new sheet in Excel. How can I update the code so that the new sheet gets the same name as the textfile that was imported?

How to&Answers:

First, when adding the new worksheet, assign it to an object variable for reference later…

Dim newWorksheet As Worksheet
Set newWorksheet = Sheets.Add(After:=Sheets("Konvertering"))

Then, you can refer to the new worksheet for your query and name your new worksheet as follows…

If Ret <> False Then
    With newWorksheet.QueryTables.Add(Connection:= _
        "TEXT;" & Ret, Destination:=newWorksheet.Range("$A$1"))
        'etc
        '
        '
    End With
    newWorksheet.Name = Mid$(Ret, InStrRev(Ret, "\") + 1)
End If

Answer:

Double InstrRev

You were just another InstrRev away from the solution.

Let’s say the path is C:\Test\Input.txt.

After applying InstrRev with \ to Ret

x = Mid$(Ret, InStrRev(Ret, "\") + 1)

you got this: Input.txt.

Now you just have to apply InstrRev with . to x

FileName = Mid$(x, 1, InStrRev(x, ".") - 1)

to get this: Input.

And now you have to get rid off x i.e. replace x in the second expression with the right side of the first expression to get this:

FileName = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
  InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)

Hence the solution:

Replace this …

newWorksheet.Name = Mid$(Ret, InStrRev(Ret, "\") + 1)

…with

newWorksheet.Name = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
  InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)

…and you’re done.

EDIT:

Links

Workbook.SaveAs

XlFileFormat

The Code

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