transfer worksheet to another excel file without extension

[Marco1975]

Hello . I'm using a macro to import the sheets of another files into my excel file. But this macro in addition to the name of the file also imports the extension . How can I modify the macro to not import the extension ??
This is the macro :

Sub Import_files2()
    Dim thisWb As Workbook
    Dim files As Variant
    Dim i As Integer
    Set thisWb = ThisWorkbook
    files = Application.GetOpenFilename(FileFilter:="Excel workbooks (*.xls),*.xls", Title:="Seleziona file da importare", MultiSelect:=True)
    If Not IsArray(files) Then Exit Sub
    For i = 1 To UBound(files)
        fpath = files(i)
        p = InStrRev(fpath, "\")
        wsname = Mid(fpath, p + 1, Len(fpath) - p)
        Workbooks.Open fpath
        With ActiveWorkbook
    .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Worksheets.Count)
    thisWb.Sheets(thisWb.Worksheets.Count).Name = wsname
    .Close False
End With
    Next
    MsgBox "Files Imported", vbInformation
End Sub

Thanks in advance for who will help me.

 

[ThauThème]

Hi Marco,

Try :

 wsname = Split(Split(fpath, "\")(UBound(Split(fpath, "\"))), ".")(0)

 

[Marco1975]

Hi ThauThème, thanks for this solution but don't working.
Vba gives me this error:
"Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook refernced by Visual Basic"

 

[ThauThème]

Hi Marco,

The solutions works but Excel do not accept 2 sheets with the same name... Try this new code :

Sub Import_files2()
Dim thisWb As Workbook
Dim files As Variant
Dim i As Integer
Dim x As Byte

Set thisWb = ThisWorkbook
files = Application.GetOpenFilename(FileFilter:="Excel workbooks (*.xls),*.xls", Title:="Seleziona file da importare", MultiSelect:=True)
If Not IsArray(files) Then Exit Sub
For i = 1 To UBound(files)
    fpath = files(i)
    wsname = Split(Split(fpath, "\")(UBound(Split(fpath, "\"))), ".")(0)
    Workbooks.Open fpath
    With ActiveWorkbook
        .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Worksheets.Count)
        On Error Resume Next
        ActiveSheet.Name = wsname
        If Err <> 0 Then
            Err.Clear
            x = x + 1
            ActiveSheet.Name = wsname & "_" & x
        End If
        On Error GoTo 0
        .Close False
    End With
Next
MsgBox "Files Imported", vbInformation
End Sub

 

[Marco1975]

Now it works but there is a problem : if in the filename there are other points before extension it doesn't work. For example:

File name: dist. unys two.xls ----> final result: dist

and if there are other file that starting in the same way the final result is:
dist
dist_1
dist_2
and so on

I'm sorry for the complication

 

[ThauThème]

Hi Marco,

Maybe with :

Sub Import_files2()
Dim thisWb As Workbook
Dim files As Variant
Dim i As Integer
Dim NAS As Byte
Dim NP As Byte
Dim EXT As String
Dim X As Byte

Set thisWb = ThisWorkbook
files = Application.GetOpenFilename(FileFilter:="Excel workbooks (*.xls),*.xls", Title:="Seleziona file da importare", MultiSelect:=True)
If Not IsArray(files) Then Exit Sub
For i = 1 To UBound(files)
    fpath = files(i)
    NAS = UBound(Split(fpath, "\"))
    NP = UBound(Split(fpath, "."))
    wsname = Split(fpath, "\")(NAS)
    EXT = Split(fpath, ".")(NP)
    wsname = Left(wsname, Len(wsame) - Len(EXT) - 1)
    'if extension have allways 3 characters you can use : wsname = Left(wsname, Len(wsame) - 4)
    Workbooks.Open fpath
    With ActiveWorkbook
        .Sheets(1).Copy After:=thisWb.Sheets(thisWb.Worksheets.Count)
        On Error Resume Next
        ActiveSheet.Name = wsname
        If Err <> 0 Then
            Err.Clear
            X = X + 1
            ActiveSheet.Name = wsname & "_" & X
        End If
        On Error GoTo 0
        .Close False
    End With
Next
MsgBox "Files Imported", vbInformation
End Sub

 

[Marco1975]

yesssssss!!!!! Perfect!!! Thank you very much ThauThème!