I found this neat code (thanks to Ron De Bruin) that takes the
selected files and incorporates each selected wookbook into 1
workbook, it also renames each sheet based on the existing filename.
I'd like to rename each sheet based upon a cell value, for example I
have a serial no in cell B6. Can someone point me in the right
direction.

Thanks
burl_h

Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long

Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn < 0)
End Function


Sub Get_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim FileNames As Variant
Dim SaveDriveDir As String
Dim ExistFolder As Boolean

'Save the current dir
SaveDriveDir = CurDir

'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\Users\Ron\test")
'It now use Excel's Default File Path

ExistFolder = ChDirNet(Application.DefaultFilePath)
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If

FileNames = Application.GetOpenFilename _
(filefilter:="xls Files (*.xls), *.xls", MultiSelect:=True)

If IsArray(FileNames) Then

On Error GoTo CleanUp

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)

'Loop through the array with csv files
For Fnum = LBound(FileNames) To UBound(FileNames)

Set mybook = Workbooks.Open(FileNames(Fnum))

'Copy the sheet of the csv file after the last sheet in
'basebook (this is the new workbook)
mybook.Worksheets(1).Copy After:= _
basebook.Sheets
(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = Right(FileNames(Fnum), Len(FileNames
(Fnum)) - _
InStrRev(FileNames(Fnum),
"\", , 1))
On Error GoTo 0

mybook.Close savechanges:=False

Next Fnum

'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0

CleanUp:

ChDirNet SaveDriveDir

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub

I'd replace this:

ActiveSheet.Name = Right(FileNames(Fnum), Len(FileNames(Fnum)) - _
InStrRev(FileNames(Fnum), "\", , 1))
With
ActiveSheet.Name = activesheet.range("B6").value

If that cell is formatted nicely (preserving leading 0's???), then maybe:
ActiveSheet.Name = activesheet.range("B6").Text






burl_h wrote:

I found this neat code (thanks to Ron De Bruin) that takes the
selected files and incorporates each selected wookbook into 1
workbook, it also renames each sheet based on the existing filename.
I'd like to rename each sheet based upon a cell value, for example I
have a serial no in cell B6. Can someone point me in the right
direction.

Thanks
burl_h

Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long

Public Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn < 0)
End Function

Sub Get_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim FileNames As Variant
Dim SaveDriveDir As String
Dim ExistFolder As Boolean

'Save the current dir
SaveDriveDir = CurDir

'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\Users\Ron\test")
'It now use Excel's Default File Path

ExistFolder = ChDirNet(Application.DefaultFilePath)
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If

FileNames = Application.GetOpenFilename _
(filefilter:="xls Files (*.xls), *.xls", MultiSelect:=True)

If IsArray(FileNames) Then

On Error GoTo CleanUp

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)

'Loop through the array with csv files
For Fnum = LBound(FileNames) To UBound(FileNames)

Set mybook = Workbooks.Open(FileNames(Fnum))

'Copy the sheet of the csv file after the last sheet in
'basebook (this is the new workbook)
mybook.Worksheets(1).Copy After:= _
basebook.Sheets
(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = Right(FileNames(Fnum), Len(FileNames
(Fnum)) - _
InStrRev(FileNames(Fnum),
"\", , 1))
On Error GoTo 0

mybook.Close savechanges:=False

Next Fnum

'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0

CleanUp:

ChDirNet SaveDriveDir

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub

--

Dave Peterson

Dave,

your solution worked great, thank you.

burl_h