Copy specific range from files in folder => enhancements needed

[markx]

Dear All,

I've found a very useful macro on Ron de Bruin's page (see below)
("Copy a range from all files that you have selected with GetOpenFilename")

Now, i would like to slightly change the last part of it:
1) instead of having the whole path copied as a name, I would prefer to have
only the workbook name
2) instead of predefined sheet name (in example: "Sheet1"), I would like to
be able to extract the range from the "active sheet"

' For testing Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = FName(N)
'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData FName(N), "Sheet1", "A1:C1", destrange, False, False
Is it feasible?
Thanks for your help!
Mark


Here's the whole original code:

Sub GetData_Example5()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim rnum As Long, destrange As Range
Dim sh As Worksheet SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
' Sort the Array
FName = Array_Sort(FName) Application.ScreenUpdating = False
'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss") 'Loop through all
files you select in the GetOpenFilename dialog
For N = LBound(FName) To UBound(FName) 'Find the last
row with data
rnum = LastRow(sh) 'create the destination cell
address
Set destrange = sh.Cells(rnum + 1, "A") ' For
testing Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = FName(N)
'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData FName(N), "Sheet1", "A1:C1", destrange, False, False
Next End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Guest]

1) To get the filename from the full pathname use this code

MyPath = ""
Do While InStr(MyFilename, "\") > 0
MyPath = MyPath & Left(MyFilename, InStr(MyFilename, "\"))
MyFilename = Mid(MyFilename, InStr(MyFilename, "\") + 1)
Loop
'remove extension from filename
RootFileName = Left(MyFilename, InStr(MyFilename, ".") - 1)