Renaming Excel Tabs 1

[Rzrbkpk]

I have script that allows users to select a folder (using a Windows API function) that contains their desired Excel files each consisting of one worksheet only. The worksheets are then compiled into seperate worksheets in a new workbook. The script works as it should, but I want to rename the tabs in the new workbook to the name of the file where the worksheet came from. I tried using "wbDst.ActiveSheet.Name = WsName" in my loop and it works for the first tab and then errors out with Run-time error 1004: Application-defined or object-defined error. Here is my code:

Private Sub workbook_open()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim WsName As String
Dim MyPath As String
Dim strFilename As String
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    'Call GetFolder Function and set folder path
    MyPath = GetFolder("")
    Set wbDst = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(MyPath & "\*.xls", vbNormal)
    
    WsName = strFilename
    
    If Len(strFilename) = 0 Then Exit Sub
    
    Do Until strFilename = ""
        
            Set wbSrc = Workbooks.Open(FileName:=MyPath & "\" & strFilename)
            
            Set wsSrc = wbSrc.Worksheets(1)
                    
            wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
            
            wbDst.Activate
            
            wbDst.ActiveSheet.Name = WsName
                                    
            wbSrc.Close False
        
        strFilename = Dir()
        
        
    Loop
    wbDst.Worksheets(1).Delete
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

And here's the API function for reference:

Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

 

[SkipVought]

hi,

    If Len(strFilename) = 0 Then Exit Sub
    
    Do Until strFilename = ""
[b]
            [highlight]WsName = strFilename[/highlight]
[/b]        
            Set wbSrc = Workbooks.Open(FileName:=MyPath & "\" & strFilename)
            
            Set wsSrc = wbSrc.Worksheets(1)
                    
            wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
            
            wbDst.Activate
            
            wbDst.ActiveSheet.Name = WsName
                                    
            wbSrc.Close False
        
        strFilename = Dir()
        
        
    Loop

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Rzrbkpk]

Thank you Skip! Works like a charm. As a side note, I did have to do some string manipulation due to Excel 31 character tab length limit.

    Do Until strFilename = ""
    
            [b][highlight]WsName = Left(strFilename, 31)
[/highlight][/b]
            Set wbSrc = Workbooks.Open(FileName:=MyPath & "\" & strFilename)
            
            Set wsSrc = wbSrc.Worksheets(1)
                    
            wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
                                
            wbDst.ActiveSheet.Name = WsName
                                    
            wbSrc.Close False
        
        strFilename = Dir()
        
        
    Loop

 

[SkipVought]

I use the File System Object rather than the DIR method, and use a For Each fsofileobject...next loop.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}