VBA - Rename worksheet after source file - vba

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