Naming Worksheet As Part Of File Name

I have a macro to loop through the files in a folder. The macro will then open up the files and copy over to a new workbook.

As I want to rename the worksheets created in the new workbook as part of the file name. Any idea how to extract the file name out and stored in a string?

Currently it will be named after the Cell A1 in the opened file. However I would like to rename as below.

Example, the file name : 030309_Mary Sales.xls, Worksheet Name to Create : Mary Sales.
File name : 030309_John King, Worksheet Name : John King

(in the code, 030309 taken from my menu sheet,D4 is the keyword , to search in files containing D4, where D3 is the directory to look in)


Sub RunCodeOnAllXLSFiles()

Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next