How to make worksheet name equal to the name of the imported file?

Question

I have a file named "127.txt". My goal is to import this file into an excel worksheet and then rename the excel worksheet to the file name (i.e. worksheet name is 127). I want to import every .txt file in a folder into seperate worksheets of the same workbook and for me to keep track of which .txt file is imported, i want the worksheet name to be the name of the .txt file

My current code is

Sub import_data()
'Access text files
Dim CPath As String 'Current work directory
Dim FPath As String 'Directory for .txt files
CPath = CurDir 
FPath = CPath & "\RAW_Data"

'Import text files into seperate sheets
Dim File As String 'File names
File = Dir(FPath & "*.txt") 'returns directory

End Sub

Not sure how to go from here

Answer 1

Import Text Files

• Carefully adjust the values in the constants section, especially the destination part.

Option Explicit

Sub ImportData()
    
    Const sSubfolder As String = "\RAW_Data\"
    Const sFilePattern As String = "*"
    Const sFileExtension As String = ".txt"
    
    Const dSubFolder As String = "\Result\"
    Const dBaseName As String = "Result"
    ' The following two '*** are dependent on each other:
    Const dFileExtension As String = ".xlsx" ' ***
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook ' ***
    
    Dim twb As Workbook: Set twb = ThisWorkbook ' workbook containing this code
    
    Dim sFolderPath As String: sFolderPath = twb.Path & sSubfolder
    If Len(Dir(sFolderPath, vbDirectory)) = 0 Then Exit Sub ' wrong folder
    
    Dim sfeLen As Long: sfeLen = Len(sFileExtension)
    Dim sFileName As String
    sFileName = Dir(sFolderPath & sFilePattern & sFileExtension)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim swbBaseName As String
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dwsCount As Long
    
    Do While Len(sFileName) > 0
        dwsCount = dwsCount + 1
        
        Set swb = Workbooks.Open(sFolderPath & sFileName)
        Set sws = swb.Worksheets(1)
        
        If dwsCount = 1 Then
            sws.Copy
            Set dwb = ActiveWorkbook
            Set dws = dwb.Worksheets(1)
        Else
            swb.Worksheets(1).Copy After:=dwb.Sheets(dwb.Sheets.Count)
            Set dws = ActiveSheet
        End If
        
        swbBaseName = Left(sFileName, Len(sFileName) - sfeLen)
        On Error Resume Next
            dws.Name = swbBaseName
        On Error GoTo 0
                   
        swb.Close SaveChanges:=False
                   
        sFileName = Dir
    Loop
         
'    Dim dFolderPath As String: dFolderPath = twb.Path & dSubFolder
'    ' Create the subfolder if it doesn't exist.
'    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then
'        MkDir dFolderPath
'    End If
'
'    dwb.SaveAs twb.Path & dSubFolder & dBaseName & dFileExtension, dFileFormat
'    dwb.Close
    
    Application.ScreenUpdating = True
    
    MsgBox "Text files imported: " & dwsCount, vbInformation

End Sub