VBA - Rename worksheet after source file

Question

I have a question as to how to rename a sheet after the source file name, but only a portion of it. So if the file name is "010117Siemens Hot - Cold Report .xls", I want just the first numbers. So in short, I would like "Sheet2" for example to be called "010117".

Sub ImportData()

    Application.ScreenUpdating = False

    Dim wkbCrntWorkBook As Workbook
    Dim wkbSourceBook   As Workbook
    Dim fNameAndPath As Variant

    Set wkbCrntWorkBook = ActiveWorkbook
    fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel 2007, *.xls; *.xlsx; *.xlsm; *.xlsa", Title:="Select File To Import")
    If fNameAndPath = False Then Exit Sub
    Call ReadDataFromSourceFile(fNameAndPath)


    Set wkbCrntWorkBook = Nothing
    Set wkbSourceBook = Nothing

    ActiveWorkbook.Worksheets("Set Up").Select

End Sub

Sub ReadDataFromSourceFile(filePath As Variant)

    Application.ScreenUpdating = False

    Dim n As Double
    Dim wksNew As Excel.Worksheet
    Dim src As Workbook
    Set src = Workbooks.Open(filePath, False, False)

    Dim srcRng As Range
    With src.Worksheets("Sheet1")
        Set srcRng = .Range(.Range("A1"), .Range("A1").End(xlDown).End(xlToRight))
    End With

    With ThisWorkbook
            Set wksNew = .Worksheets.Add(After:=.Worksheets(.Sheets.Count))
            n = .Sheets.Count
            .Worksheets(n).Range("A1").Resize(srcRng.Rows.Count, srcRng.Columns.Count).Value = srcRng.Value
    End With


    ' CLOSE THE SOURCE FILE.
    src.Close False             ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing

End Sub

Thanks in advance!

Answer 1

Use the RegEx object to extract the numeric part (from 1 to 9 consecutive numeric) from the file name (src.Name).

Code

Sub ReadDataFromSourceFile(filePath As Variant)

    Application.ScreenUpdating = False

    Dim n As Double
    Dim wksNew As Excel.Worksheet
    Dim src As Workbook
    Set src = Workbooks.Open(filePath, False, False)

    Dim srcRng As Range
    With src.Worksheets("Sheet1")
        Set srcRng = .Range(.Range("A1"), .Range("A1").End(xlDown).End(xlToRight))
    End With

    With ThisWorkbook
            Set wksNew = .Worksheets.Add(After:=.Worksheets(.Sheets.Count))
            n = .Sheets.Count
            .Worksheets(n).Range("A1").Resize(srcRng.Rows.Count, srcRng.Columns.Count).Value = srcRng.Value
    End With

    ' ======= get the digits part from src.Name using a RegEx object =====
    ' RegEx variables
    Dim Reg As Object
    Dim RegMatches As Variant

    Set Reg = CreateObject("VBScript.RegExp")
    With Reg
        .Global = True
        .IgnoreCase = True
        .Pattern = "\d{0,9}" ' Match any set of 0 to 9 digits
    End With

    Set RegMatches = Reg.Execute(src.Name)
    If RegMatches.Count >= 1 Then ' make sure there is at least 1 match
        ThisWorkbook.Worksheets(n).Name = RegMatches(0) ' rename new sheets to the numeric part of the filename
    End If


    ' CLOSE THE SOURCE FILE.
    src.Close False             ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing

End Sub