VBA Error Message.... What am i missing?

[SamBo1234]

Hi all,

I have the following Code which works when i run it manually,


MODULE1

Option Explicit

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim ShCnt As Integer
    Dim i As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        
        With ThisWorkbook
        ShCnt = .Sheets.Count
        Sheets().Move After:=.Sheets(ShCnt)
            For i = ShCnt + 1 To .Sheets.Count
      .Sheets(i).Range("I1") = Dir(FilesToOpen(x))
        Range("I1").Select
        Selection.Font.Bold = True
            Next i
        End With
        
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

(It basically combines workbooks into one, This works and i have no problems)

This is my code for creating a button on the menu, and runs the SUB above when clicked.


THIS WORKBOOK

Option Explicit


Dim sMenu As String


Private Sub Workbook_BeforeClose(Cancel As Boolean)


    sMenu = "myButton"


    On Error Resume Next
    Application.CommandBars("Formatting").Controls(sMenu).Delete
    On Error GoTo 0
End Sub


Private Sub Workbook_Open()
Dim oCB As CommandBar
Dim oCtl As CommandBarControl
Dim newMenu As Object 'CommandBarControl
Dim ctrlButton As Object 'CommandBarControl


    sMenu = "Merge Workbooks"


    On Error Resume Next
    Application.CommandBars("Formatting").Controls(sMenu).Delete
    On Error GoTo 0


    Set oCB = Application.CommandBars("Formatting")
    Set oCtl = oCB.Controls.Add(Type:=msoControlButton, temporary:=True)


    With oCtl
        .BeginGroup = True
        .Caption = sMenu
        .FaceId = 197
        .Style = msoButtonIconAndCaption
        .OnAction = "CombineWorkbooks"
        
    End With


End Sub

When i click my pre made button it then runs the SUB to Combine workbooks but i get the following error message....


Microsoft Excel
Method 'Move' of objects 'Sheets' failed


Any ideas?

The top SUB works when i run it manually, but not when i run it when i click the button.... i cant figure it out.

FYI This is a XLA Addin i have created.

Ty for any input.
Sam

 

[SamBo1234]

Excellent!, Richard

Got it all working thats great!.

Again thank you guys for support, ill be sure to come back with more headaches in the future!

Best wishes
Sam

 

[SamBo1234]

One tiny little problem i just spotted,

.Sheets(i).Range("I1") = Dir(FilesToOpen(x))

This normal sticks the File name of the imported workbooks into 'I1' but for some reason its now stopped working just for the first imported workbook, but for all others it works..

Any Ideas ?

 

[Richard Schollar]

Option Explicit 

Sub CombineWorkbooks() 
    Dim FilesToOpen 
    Dim x As Integer 
    Dim ShCnt As Integer 
    Dim i As Integer, strFile as String 

    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 

    FilesToOpen = Application.GetOpenFilename _ 
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ 
      MultiSelect:=True, Title:="Files to Merge") 

    If TypeName(FilesToOpen) = "Boolean" Then 
        MsgBox "No Files were selected" 
        GoTo ExitHandler 
    End If 

    x = 1 
    strFile = right(FilesToOpen(1),len(FilesToOpen(1))-instrrev(FilesToOpen(1),"\")) 
    While x <= UBound(FilesToOpen) 
        Workbooks.Open Filename:=FilesToOpen(x) 
        If x=1 Then             
             for i=1 to workbooks(strfile).Sheets.Count
                 workbooks(strfile).Sheets(i).Range("I1") =   Dir(FilesToOpen(x))
                  Workbooks(strfile).Sheets(i).Range("I1").Font.Bold = True
             Next i
         End If  
        With Workbooks(strFile) 
                ShCnt = .Sheets.Count 
                Sheets().Move After:=.Sheets(ShCnt) 
                For i = ShCnt + 1 To .Sheets.Count 
                   .Sheets(i).Range("I1") = Dir(FilesToOpen(x)) 
                   .Sheets(i).Range("I1").Font.Bold = True 
                Next i 
        End With 
        
        x = x + 1 
    Wend 

ExitHandler: 
    Application.ScreenUpdating = True 
    Exit Sub 

ErrHandler: 
    MsgBox Err.Description 
    Resume ExitHandler 
End Sub

See if this sorts it

 

[SamBo1234]

Eureka!

Cheers m8.