Excel Automation Error: Run-time error '-2147417848 (80010108)' - vba

I am new to VBA (and Excel for that matter) so please keep that in mind when reviewing my code. This is also my first post here!
I am trying to complete and refine my file, but I have run into a error that I cannot seem to fix or even understand. I have searched this site (and many others) and found many people with this same error, but their resolutions are irrelevant and/or don't solve my problem.
This is the error I receive:
"Automation Error. The object invoked has disconnected from its clients."
If I click debug, end, or help, Excel crashes and (sometimes) reopens an recovered file. SO frustrating!
I have managed to locate the line of code that causes this:
templateSheet.Copy After:=indexSheet
templateSheet and indexSheet are defined references to specific worksheets
The gist of what happens within this part of my file:
I've created a userform and a form control button. The button shows the userform. The userform has two fields asking the user to enter names. The code (all in the userform) checks all worksheet names.
If the name exists, it tells the user to choose a different name.
If the name doesn't exist, a hidden template sheet (templateSheet) is copied and pasted after the homepage sheet (indexSheet) and renamed based on the user input.
A table on the homepage gets a new row and a hyperlink to the new sheet is added.
There is additional code that adds values to cells on multiple sheets and formats that text.
All of this works perfectly for 21 runs. On the 22nd run, without fail, the automation error pops up and Excel crashes.
This happens on windows with Excel 2010, 2011, and 2016 (I've yet to test other versions on Excel) on a range of Windows versions. Bizzarly, the file works PERFECTLY on my 2013 MacBook pro with Excel 2011.. no errors at all.
The code I provide at the end of this post is the majority of the code within the file. At first, I thought it may be a memory issue but I think this is a pretty simple file, something excel and my desktop should be able to handle.
What I've done so far to try to fix it:
Option explicit
Keep templateSheet visible at all times
Create a separate Excel template file and call that from the userform
Changed .Activate and .Select to defined ranges
Copy and paste the new template sheet without specifying where to put it
Made sure all calls to sheets included specific "path" (ThisWorkbook.)
Inefficient workaround:
The only thing that prevents this error is code to save, close, and reopen the file. Obviously, this is time consuming and not efficient. I found this code online:
wb.Save
Application.OnTime Now + TimeValue("00:00:01"), Application.Workbooks.Open(filePath)
wb.Close (True)
Finally:
As I stated, I am new to VBA, coding, and this site. Any suggestions to my code, relevant to this issue or not, are greatly appreciated. I have included all the code from my UserForm.
Private Sub OkButton_Click()
'Dont update the screen while the macro runs
Application.ScreenUpdating = False
'Sheet and workbook variables
Dim wb As Workbook
Dim indexSheet As Worksheet, templateSheet As Worksheet
Dim templateCopy As Worksheet, newSheet As Worksheet
'Table and new row variables
Dim Tbl As ListObject
Dim NewRow As ListRow
'Variables to group shapes based on
'need to hide or show them
Dim hideShapes() As Variant, showShapes() As Variant
Dim hideGroup As Object, showGroup As Object
'Misc variables
Dim i As Integer
Dim exists As Boolean
Dim filePath As String
'Variables to assign ranges
Dim scenarioRng As Range
Dim traceabilityFocus As Range
Dim testCaseRng As Range
Dim statusRng As Range
Dim newSheetTestCaseRng As Range
Dim newSheetStatusRng As Range
Dim newSheetFocus As Range
Dim newSheetDateRng As Range
'Create array of shapes based on visibility rules
hideShapes = Array("TextBox 2", "Rectangle 1")
showShapes = Array("TextBox 15", "TextBox 14", "TextBox 13", "TextBox 11", "StatsRec", "Button 10")
'To reference Traceability Matrix sheet
Set indexSheet = ThisWorkbook.Sheets("Traceability Matrix")
'To reference Template sheet
Set templateSheet = ThisWorkbook.Sheets("TestCase_Template")
'To reference traceability matrix table
Set Tbl = indexSheet.ListObjects("TMatrix")
'Set hideShapes to a hide group
Set hideGroup = indexSheet.Shapes.Range(hideShapes)
'Set show shapes to a show group
Set showGroup = indexSheet.Shapes.Range(showShapes)
'To reference this workbook
Set wb = ThisWorkbook
'Get file path of this workbook and set it to string
filePath = wb.FullName
'If the userform fields are empty then show error message
If ScenarioNameBox.Value = "" Or TestCaseNameBox.Text = "" Then
MsgBox ("Please complete both fields.")
'If the userform fields are completed and a worksheet with
'the same name exists, set boolean to true
Else
For i = 1 To Worksheets.Count
If ThisWorkbook.Worksheets(i).Name = TestCaseNameBox.Value Then
exists = True
End If
'Iterate through all worksheets
Next i
'If test case name already exists, show error message
If exists Then
MsgBox ("This test case name is already in use. Please choose another name.")
'If test case name is unique, update workbook
Else
'Copy template sheet to after traceability matrix sheet
templateSheet.Copy After:=indexSheet 'LOCATION OF ERROR!!!
'Ensure template sheet is hidden
templateSheet.Visible = False
'To reference copy of template
Set templateCopy = ThisWorkbook.Sheets("TestCase_Template (2)")
'Rename template sheet to the test case name
templateCopy.Name = TestCaseNameBox.Value
'To reference re-named template sheet
Set newSheet = ThisWorkbook.Sheets(TestCaseNameBox.Value)
'Show new sheet
newSheet.Visible = True
'Set focus to traceability matrix
Set traceabilityFocus = indexSheet.Range("A1")
'Add a new row
Set NewRow = Tbl.ListRows.Add(AlwaysInsert:=True)
'Set ranges for cells in traceability table
Set scenarioRng = indexSheet.Range("B" & NewRow.Range.Row)
Set testCaseRng = scenarioRng.Offset(0, 1)
Set statusRng = testCaseRng.Offset(0, 1)
'Set scenario cell with name and format
With scenarioRng
.FormulaR1C1 = ScenarioNameBox.Value
.HorizontalAlignment = xlGeneral
.Font.Name = "Arial"
.Font.Size = 12
End With
'Set test case cell with name, hyperlink to sheet, and format
With testCaseRng
.FormulaR1C1 = TestCaseNameBox.Value
.Hyperlinks.Add Anchor:=testCaseRng, Address:="", SubAddress:=newSheet.Name & "!A1", TextToDisplay:=newSheet.Name
.HorizontalAlignment = xlGeneral
.Font.Name = "Arial"
.Font.Size = 12
End With
'Set trial status as Incomplete and format
With statusRng
'Set new test case to "Incomplete"
.Value = "Incomplete"
.Font.Name = "Arial"
.Font.Size = 12
.Font.Color = vbBlack
End With
'Show or hide objects
hideGroup.Visible = False
showGroup.Visible = True
'Set ranges for cells in test case table
Set newSheetTestCaseRng = newSheet.Range("C2")
Set newSheetStatusRng = newSheet.Range("C12")
Set newSheetDateRng = newSheet.Range("C5")
'Insert test case name into table
newSheetTestCaseRng.Value = TestCaseNameBox.Value
'Add todays date to Date Created
newSheetDateRng.Value = Date
'Set status to "Incomplete"
newSheetStatusRng.Value = "Incomplete"
'End with cursor at beginning of table
newSheet.Activate
Range("C3").Activate
'wb.Save
'Application.OnTime Now + TimeValue("00:00:01"), Application.Workbooks.Open(filePath)
'wb.Close (True)
'Close the userform
Unload Me
End If
End If
'Update screen
Application.ScreenUpdating = True
End Sub
===========================================================================
Update:
Using the code provided by #DavidZemens the error acts differently. Normally, the userform closes after each sheet is created. #DavidZemens suggested leaving the form open so the user can make as many sheets as they need in one go. This method allows me to create a seemingly unlimited amount of sheets WITHOUT error. Read: at the 22 sheet mark, there is no error.
However, if I manually close the userform after making more than 22 sheets and then reopen it to create a new sheet, the automation error pops up again and excel crashes.
The new code that causes this error is here:
With templateSheet
.Visible = xlSheetVisible
.Copy Before:=indexSheet 'ERRORS HERE!!
.Visible = xlSheetVeryHidden
Another thing worth mentioning: In the project explorer it lists all my sheets with their names. But, there are extra sheets in there that have the workbook icon next to them. I did not create any of there workbooks or worksheets and my macros do not create or even call any workbook other than ThisWorkbook.

I don't have any idea if this will solve the problem, but I tried to clean up the code a bit. See if this helps. I created about 28 sheets without any error.
There is some consolidation/cleanup but I wouldn't expect that to be substantial. However, I did remove the call to Unload Me which isn't strictly necessary (the user can always close out of the form manually, and by omitting that line we also allow the user to create as many sheets as he or she wants without having to launch the form anew each time).
Option Explicit
Private Sub OkButton_Click()
'Dont update the screen while the macro runs
Application.ScreenUpdating = False
'Sheet and workbook variables
Dim wb As Workbook
Dim indexSheet As Worksheet, templateSheet As Worksheet
Dim templateCopy As Worksheet, newSheet As Worksheet
'Table and new row variables
Dim Tbl As ListObject
Dim NewRow As ListRow
'Variables to group shapes based on
'need to hide or show them
Dim hideShapes() As Variant, showShapes() As Variant
Dim hideGroup As Object, showGroup As Object
'Misc variables
Dim i As Integer
Dim exists As Boolean
Dim filePath As String
'Variables to assign ranges
Dim scenarioRng As Range
Dim traceabilityFocus As Range
Dim testCaseRng As Range
Dim statusRng As Range
Dim newSheetTestCaseRng As Range
Dim newSheetStatusRng As Range
Dim newSheetFocus As Range
Dim newSheetDateRng As Range
'Create array of shapes based on visibility rules
hideShapes = Array("TextBox 2", "Rectangle 1")
showShapes = Array("TextBox 15", "TextBox 14", "TextBox 13", "TextBox 11", "StatsRec", "Button 10")
'To reference this workbook
Set wb = ThisWorkbook
'To reference Traceability Matrix sheet
Set indexSheet = wb.Sheets("Traceability Matrix")
'To reference Template sheet
Set templateSheet = wb.Sheets("TestCase_Template")
'To reference traceability matrix table
Set Tbl = indexSheet.ListObjects("TMatrix")
'Set hideShapes to a hide group
Set hideGroup = indexSheet.Shapes.Range(hideShapes)
'Set show shapes to a show group
Set showGroup = indexSheet.Shapes.Range(showShapes)
'Get file path of this workbook and set it to string
filePath = wb.FullName
'If the userform fields are empty then show error message
If ScenarioNameBox.Value = "" Or TestCaseNameBox.Text = "" Then
MsgBox "Please complete both fields."
GoTo EarlyExit
'If the userform fields are completed and a worksheet with
'the same name exists, set boolean to true
Else
On Error Resume Next
Dim tmpWS As Worksheet
' This will error if sheet doesn't exist
Set tmpWS = wb.Worksheets(TestCaseNameBox.Value)
exists = Not (tmpWS Is Nothing)
On Error GoTo 0
End If
'If test case name already exists, show error message
If exists Then
MsgBox "This test case name is already in use. Please choose another name."
GoTo EarlyExit
'If test case name is unique, update workbook
Else
'Copy template sheet to after traceability matrix sheet
With templateSheet
.Visible = xlSheetVisible
.Copy Before:=indexSheet
.Visible = xlSheetVeryHidden
End With
Set newSheet = wb.Sheets(indexSheet.Index - 1)
With newSheet
newSheet.Move After:=indexSheet
'Rename template sheet to the test case name
.Name = TestCaseNameBox.Value
'To reference re-named template sheet
.Visible = True
'Set ranges for cells in test case table
Set newSheetTestCaseRng = .Range("C2")
Set newSheetStatusRng = .Range("C12")
Set newSheetDateRng = .Range("C5")
'Insert test case name into table
newSheetTestCaseRng.Value = TestCaseNameBox.Value
'Add todays date to Date Created
newSheetDateRng.Value = Date
'Set status to "Incomplete"
newSheetStatusRng.Value = "Incomplete"
'End with cursor at beginning of table
.Activate
.Range("C3").Activate
End With
'Set focus to traceability matrix
Set traceabilityFocus = indexSheet.Range("A1")
'Add a new row
Set NewRow = Tbl.ListRows.Add(AlwaysInsert:=True)
'Set ranges for cells in traceability table
Set scenarioRng = indexSheet.Range("B" & NewRow.Range.Row)
Set testCaseRng = scenarioRng.Offset(0, 1)
Set statusRng = testCaseRng.Offset(0, 1)
'Set scenario cell with name and format
With scenarioRng
.FormulaR1C1 = ScenarioNameBox.Value
.HorizontalAlignment = xlGeneral
.Font.Name = "Arial"
.Font.Size = 12
End With
'Set test case cell with name, hyperlink to sheet, and format
With testCaseRng
.FormulaR1C1 = TestCaseNameBox.Value
.Hyperlinks.Add Anchor:=testCaseRng, Address:="", SubAddress:=newSheet.Name & "!A1", TextToDisplay:=newSheet.Name
.HorizontalAlignment = xlGeneral
.Font.Name = "Arial"
.Font.Size = 12
End With
'Set trial status as Incomplete and format
With statusRng
'Set new test case to "Incomplete"
.Value = "Incomplete"
.Font.Name = "Arial"
.Font.Size = 12
.Font.Color = vbBlack
End With
'Show or hide objects
hideGroup.Visible = False
showGroup.Visible = True
wb.Save
End If
EarlyExit:
'Update screen
Application.ScreenUpdating = True
End Sub

hope this helps - I was updating a table with UserForm but at the same time had a named range defined which was reading the column values from the same table using INDIRECT. After removing the named range all works fine.

Related

Excel VBA Copying data from another workbook using cell reference

I have the filename stated in cell B1 and I'm trying to import data from another sheet. Currently this is throwing subscription-out-of-range error. Any simple way to fix this? Or another preferred way to do this? The only requirement is to have cells containing data (text) from another workbook, not formula referring to it.
Sub UpdateFileInfo()
If (Range("B1") = "") Then
Range("A2:R200").Value = ""
Else
Filename = Range("B1").Value
Range("A2:R200") = Workbooks(Filename).GetActiveSheet.Range("A2:R200").Value
End If
End Sub
if you already know the source sheet name (e.g.: "Sheet1") you could use this
Option Explicit
Sub UpdateFileInfo2()
With Range("A2:R200") ' reference target range
If Range("B1") = "" Then ' if currently active sheet B1 cell is empty
.ClearContents ' clear referenced range content
Else
.FormulaR1C1 = "='C:\Users\...\[" & Range("B1").Value & "]Sheet1'!RC" ' fill referenced range with formulas pointing at the corresponding cell in the wanted sheet of the wanted workbook
.Value = .Value ' get rid of formulas and leave values only
End If
End With
End Sub
otherwise, you could use this pattern:
Sub UpdateFileInfo2()
With Range("A2:R200") ' reference target range
If Range("B1") = "" Then ' if currently active sheet B1 cell is empty
.ClearContents ' clear referenced range content
Else
.Value = Workbooks.Open(Range("B1").Value).ActiveSheet.Range(.Address).Value ' have refereneced range values as the newly opened workbook activesheet corresponding one
ActiveWorkbook.Close false ' close newly opened workbook
End If
End With
End Sub
while, should your Range("B1").Value not contain the full path of your file, then add it:
Sub UpdateFileInfo2()
With Range("A2:R200") ' reference target range
If Range("B1") = "" Then if currently active sheet B1 cell is empty
.ClearContents ' clear referenced range content
Else
.Value = Workbooks.Open("C:\Users\...\" & Range("B1").Value).ActiveSheet.Range(.Address).Value ' have refereneced range values as the newly opened workbook activesheet corresponding one
ActiveWorkbook.Close false ' close newly opened workbook
End If
End With
End Sub
You are getting this error because the Workbook is not open.
To do that, you'll have to include a line before the command that writes to range("A2:R200") that opens the workbook. But then, you'll have more than one workbook open, so you might want to use variables to make this cleaner like this:
Sub UpdateFileInfo()
Dim LocalWorkbook As Workbook
Dim RemoteWorkbook As Workbook
Set LocalWorkbook = ActiveWorkbook
If (Range("B1") = "") Then
Range("A2:R200").Value = ""
Else
FullFilename = Range("B1").Value
Set RemoteWorkbook = Workbooks.Open(Filename:=FullFilename, ReadOnly:=True)
LocalWorkbook.ActiveSheet.Range("A2:R200") = RemoteWorkbook.ActiveSheet.Range("A2:R200").Value
RemoteWorkbook.Close SaveChanges:=False
End If
End Sub
In general, when you get a subscription-out-of-range error, it's because you are referring to an element of a collection (in this case the workbooks collection) or an element of an array using a key or an index that does not exist.

How to copy range of cells using inputbox and paste to newly created sheet

It's my 1st time here and needed some help. not good with coding as I just started with the help of youtube. I saw a post here that helps you create sheets with VBA. and this is what i started on. MAybe you can help me along the way.
Sub cutcell()
Dim number, name As Variant
'ask the number of cell and name of new sheet
number = InputBox("Number of cells to cut")
name = InputBox("Name of new sheet")
' select Cell from A1 to the number of sheet inputted
Range("A1:A(number)").Select
Selection Cut
'creates a new worksheet
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).name = name.Value ' renames the new worksheet
Range("A1").Select
activeheet.Paste
End Sub
Try it like this...
Sub cutcell()
Dim wsNew As Worksheet
Dim RngToCut As Range
Dim number, NewName As Variant
Application.ScreenUpdating = False
'ask the number of cell and name of new sheet
number = Application.InputBox("Number of cells to cut", Type:=1) 'This will only allow a number input
If number = 0 Then
MsgBox "You didn't enter number.", vbCritical
Exit Sub
End If
Set RngToCut = Range("A1:A" & number)
'Ask user to input name of the New Sheet
NewName = InputBox("Name of new sheet")
If NewName = "" Then
MsgBox "You didn't input the name of New Sheet.", vbCritical, "New Sheet Name Missing!"
Exit Sub
End If
Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
wsNew.name = NewName
RngToCut.Cut wsNew.Range("A1")
Application.ScreenUpdating = True
End Sub
One problem is here:
Range("A1:A(number)").Select
You need to work out the range but putting it in quotes takes it as literally what you say. Try this:
Range("A1:A" + number).Select
Another problem is here:
activeheet.Paste
You have misspelled ActiveSheet. Try:
ActiveSheet.Paste
It's better if you stay away from Select, Selection and ActiveSheet, and instead use fully qualified Range and Worksheets objects.
Read here How to avoid using Select in Excel VBA .
Also, the Cut>>Paste is a 1-line syntax (see code below), just try to keep the 2 actions as close as can be (create the new Worksheet object before this action).
Code
Option Explicit
Sub cutcell()
Dim number As Long, name As String
Dim OrigSht As Worksheet
Dim NewSht As Worksheet
'ask the number of cell and name of new sheet
number = InputBox("Number of cells to cut")
name = InputBox("Name of new sheet")
' save the currebt active sheet
Set OrigSht = ActiveSheet ' <-- I still prefer to use Worksheets("SheetName")
' first create the new worksheet
Set NewSht = Sheets.Add(After:=Sheets(Sheets.Count))
NewSht.name = name ' renames the new worksheet
' select Cell from A1 to the number of sheet inputted , use Cut>>Paste in 1 line
OrigSht.Range("A1:A" & number).Cut Destination:=NewSht.Range("A1")
End Sub
A inputbox type 8 could be used for that purpose, since it lets user pick the desired range.
You might find other examples in here.
Cris

Subscript out of range error - vba

I am trying to copy and paste multiple tables from excel to word but it's giving me Subscript out of range error when I am trying to define tbl. I found the codes online and is trying to modify the codes to suit my needs.
Sub ExcelTablesToWord_Modified()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim sheet As Excel.Worksheet
Dim tableName As String
With dict
.Add "TableA1", "TableA1"
.Add "TableA2", "TableA2"
.Add "TableB1", "TableB1"
.Add "TableB2", "TableB2"
.Add "TableC", "TableC"
.Add "TableD", "TableD"
.Add "TableE1", "TableE1"
.Add "TableE2", "TableE2"
.Add "TableF1", "TableF1"
.Add "TableF2", "TableF2"
'TODO: add the remaining WorksheetName/TableName combinations
End With
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
tableName = dict(sheet.Name)
'Copy Table Range from Excel
sheet.ListObjects(tableName).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(tableName).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Below will copy the first Table in every worksheet and paste into Word doc, regardless of the Table Name. The bookmark names in the Word doc assumed to be simply start at 1 with prefix "bookmark".
If specific Table names are really required, then create a Collection for the names, and loop through each Table in each Worksheet, if that table name is in the Collection then proceed to copy.
Option Base 1 'Force arrays to start at 1 instead of 0
Sub ExcelTablesToWord()
Dim oWS As Worksheet
Dim tbl As Excel.Range
Dim WordApp As Object ' Word.Application
Dim myDoc As Object ' Word.Document
Dim x As Long ' Integer
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
If WordApp Is Nothing Then GoTo WordDocNotFound
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
If myDoc Is Nothing Then Set myDoc = WordApp.Documents.Open("a.docx")
If myDoc Is Nothing Then GoTo WordDocNotFound
'Loop Through and Copy/Paste Multiple Excel Tables
x = 1 ' For x = LBound(TableArray) To UBound(TableArray)
For Each oWS In ThisWorkbook.Worksheets
'Copy Table Range from Excel
'Set tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range
Set tbl = oWS.ListObjects(1).Range
If Not tbl Is Nothing Then
tbl.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks("bookmark" & x).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
'Autofit Table so it fits inside Word Document
myDoc.Tables(x).AutoFitBehavior 2 ' (wdAutoFitWindow)
x = x + 1
End If
Next
On Error GoTo 0
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
The code I had originally provided was based on your original model, in which the corresponding Worksheet, Table, and Bookmark in each set had a different name.
Now that you have ensured that the names of the objects in each set are identical (which is a better model), try the following procedure. The only difference is that the Scripting.Dictionary has been eliminated, and the Worksheet name is being used to provide both the name of the Table and the name of the Bookmark (since all three values match now).
As before, this one has also been tested in Excel/Word 2016, and is functioning as expected:
Public Sub ExcelTablesToWord_Modified2()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim sheet As Excel.Worksheet
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
'Copy Table Range from Excel
sheet.ListObjects(sheet.Name).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(sheet.Name).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
If you still receive the same error, then perhaps the Workbook is corrupted. In that case, try doing the following:
Create a new Workbook with one Worksheet
Rename the Worksheet so that its name matches the name of one of the Bookmarks in the Word document
Manually add a single, small, "testing-only" Table to the Worksheet (do not copy/paste one from the original Workbook)
Ensure that the Table's name is the same as the Worksheet's name
Copy/paste the above procedure into a new Module in that Workbook
Save the new Workbook
Ensure your Word document is open, and run the procedure
If that works, then you might consider recreating your entire original Workbook in the new Workbook. When doing so, if your datasets are large enough that you must copy/paste from the Original Workbook, use "Paste Special" with "Values Only" instead of just a normal Paste. Then, re-create any missing formatting manually. That way, it will be less likely that any corruption in the original Workbook will be transferred to the new one.

Macro that loops through drop down and creates a worksheet for each drop down selection

So I have a dashboard sheet named "Business Plans" where I have a dropdown in cell A2 that's a dropdown selection of a range called "Facilities" and all dashboard data are driven off of lookups. What I want to do is First create a new workbook than a new tab for each dropdown selection with the tab in the same format but the data pasted as values. I attempted the following code that I created to save every dropdown selection as PDF but I have been unsuccessful. Any insight on how I can get this code working will be great.
Sub Worksheet_Generator()
Dim cell As Range
Dim wsSummary As Worksheet
Dim counter As Long
Set wsSummary = Sheets("Business Plans")
For Each cell In Worksheets("dd").Range("$C3:$C75")
If cell.Value = "" Then
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
Else
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
With wsSummary
.Range("$A$2").Value = cell.Value
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
End With
End If
Next cell
Set wsSummary = Nothing
End Sub
I think you are looking for something like the below (adapted from copying-dynamic-rows-into-new-workbook-and-save-it).
Option Explicit
Sub grabber()
Dim thisWb As Workbook: Set thisWb = ThisWorkbook
Dim thisWs As Worksheet: Set thisWs = thisWb.Worksheets("dd") 'replace with relevant name
Dim newBook As Workbook
Dim newws As Worksheet
Dim pathToNewWb As String
Dim uKeys
Dim currentPath, columnWithKey, numCols, numRows, uKey, dataStartRow, columnKeyName
'nobody likes flickering screens
Application.ScreenUpdating = False
'remove any filter applied to the data
thisWs.AutoFilterMode = False
'get the path of the workbook folder
currentPath = Application.ThisWorkbook.Path
'Set the stage
'###Hardcode###
columnKeyName = "Facility" 'name of the column with the facility values
dataStartRow = 4 'this is a pure guess, correct as relevenat. Use the header row index
pathToNewWb = currentPath & "/Business Plans.xlsx" ' where to put the new excel, if you want a saveas prompt you should google "Application.FileDialog(msoFileDialogSaveAs)"
uKeys = Range("Facilities").Value
'###Hardcode End###
columnWithKey = thisWs.Range(dataStartRow & ":" & dataStartRow).Find(what:=columnKeyName, LookIn:=xlValues).Column
numCols = thisWs.UsedRange.Columns.Count
'extract the index of the last used row in the worksheet
numRows = thisWs.UsedRange.Rows.Count
'create the new workbook
Set newBook = Workbooks.Add
'loop the facilities, and do the work
For Each uKey In uKeys
'Filter the keys column for a unique key
thisWs.Range(thisWs.Cells(dataStartRow, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey
'copy the sheet
thisWs.UsedRange.Copy
'Create a new ws for the facility, and paste as values
Set newws = newBook.Worksheets.Add
With newws
.Name = uKey 'I assume the name of the facility is the relevant sheet name
.Range("A1").PasteSpecial xlPasteValues
End With
'remove autofilter (paranoid parrot)
thisWs.AutoFilterMode = False
Next uKey
'save the new workbook
newBook.SaveAs pathToNewWb
newBook.Close
End Sub
EDIT:
As I have not seen your data, I would not be surprised if it requires some revision.
First I try to "frame" the range of the worksheet "dd" that contains the data (the ###Hardcode### bit), define the path for the output, and identify the column that can be filtered for the values corresponding to the named range "Facilities".
I retrieve the values of the named range "Facilities" (into uKeys), and create the output workbook (newBook). Then we go through each value (uKey) from the uKeys in the for loop. Within the loop, I apply an autofilter for the uKey. The filtration is followed by creation of a sheet (newWs) in newBook, and a copy paste of the filtered worksheet "dd" into newWs. we then turn off the autofilter, and the worksheet "dd" is returned to its unfiltered state.
At the end we save newBook to the desired location, and close it.

Run-Time error: 1004 Unable to get the ListIndex property of the ListBox Class

I have a very old Excel spreadsheet within a macro in it.
Usage is: start the spreadsheet, push button, select a few other spreadsheets, complete copy and paste in one spreadsheet file.
It works with Office Excel 2007, but not with Office 2013.
When the macro starts, once the files to be appended have been selected, Excel reports:
Run-Time error: 1004
Unable to get the ListIndex property of the ListBox Class
then, when I click on debug, it mark this VBA row in yellow:
Set wbData = Workbooks.Open(wbLauncher.Worksheets("config").Cells(Worksheets("config").Range("Program1").Row - 1 + shtActive.Shapes(1).ControlFormat.ListIndex, Worksheets("config").Range("Program1").Column), , True)
edit adding the whole code
Sub btnSelectData()
Dim fd As FileDialog, shtActive As Worksheet, fItem As Variant, cID As Integer, rID As Integer
Set shtActive = ActiveSheet
shtActive.Range("D:D").ClearContents
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = True
fd.InitialFileName = Worksheets("config").Range("dataPath")
fd.Show
cID = Worksheets("GUI").Range("Data1").Column
rID = Worksheets("GUI").Range("Data1").Row
For Each fItem In fd.SelectedItems
shtActive.Cells(rID, cID) = fItem
rID = rID + 1
Next
End Sub
Public Sub LoadData(ByVal fName As String)
Dim shtActive As Worksheet, wbData As Workbook
Set shtActive = ActiveSheet
shtActive.Cells(1, 1).Select
If fName <> "" Then
Set wbData = Workbooks.Open(fName, , True)
If wbData.Worksheets.Count < 1 Then
MsgBox "No data found in " & fName
Else
wbData.Worksheets(1).Cells.Select
Selection.Copy
shtActive.Activate
ActiveSheet.Paste
shtActive.Cells(1, 1).Select
End If
Selection.Clear
wbData.Close
End If
End Sub
Sub btnLaunch()
Dim wbLauncher As Workbook, shtActive As Worksheet, wbData As Workbook, shtItem As Worksheet
Set wbLauncher = ActiveWorkbook
Set shtActive = ActiveSheet
Application.WindowState = xlMinimized
Set wbData = Workbooks.Open(wbLauncher.Worksheets("config").Cells(Worksheets("config").Range("Program1").Row - 1 + shtActive.Shapes(1).ControlFormat.ListIndex, Worksheets("config").Range("Program1").Column), , True)
For Each shtItem In wbData.Worksheets
If UCase(Left(shtItem.Name, 5)) = "DATA_" Then
shtItem.Activate
LoadData wbLauncher.Worksheets("GUI").Cells(wbLauncher.Worksheets("GUI").Range("Data1").Row - 1 + Val(Right(shtItem.Name, Len(shtItem.Name) - 5)), wbLauncher.Worksheets("GUI").Range("Data1").Column)
End If
Next
wbData.Worksheets(1).Activate
Application.WindowState = xlNormal
End Sub
Edit
I've added a loop which goes through the listbox and checks if it is selected, if it is it executes the code as before but then continues until all listbox items are checked.
Sub btnLaunch()
Dim wbLauncher As Workbook, shtActive As Worksheet, wbData As Workbook, shtItem As Worksheet
Dim i As Long
Set wbLauncher = ActiveWorkbook
Set shtActive = ActiveSheet
Application.WindowState = xlMinimized
For i = 1 To shtActive.ListBoxes(1).ListCount
If shtActive.ListBoxes(1).Selected(i) Then
Set wbData = Workbooks.Open(wblauncer.Worksheets("Config").Cells(Worksheets("confige").Range("Program1") - 1 + i, Worksheets("Config").Range("Program1").Column), , True)
For Each shtItem In wbData.Worksheets
If UCase(Left(shtItem.Name, 5)) = "DATA_" Then
shtItem.Activate
LoadData wbLauncher.Worksheets("GUI").Cells(wbLauncher.Worksheets("GUI").Range("Data1").Row - 1 + Val(Right(shtItem.Name, Len(shtItem.Name) - 5)), wbLauncher.Worksheets("GUI").Range("Data1").Column)
End If
Next shtItem
wbData.Worksheets(1).Activate
Next i
Application.WindowState = xlNormal
End Sub
End of edit
You must set the selection type of your listbox on the worksheet to "Single", the reason you're getting the error is because currently it is set to either "Multi" or "Extend". You can right click the listbox and click on "Format Control"
All the information I found, states that the FormatControl.ListIndex property does not work when the selection type is set to anything but "Single"
Looking at your code, it would seem illogical to select multiple lines anyway. The Workbook.Open can only open one file at the time. You can of course incorporate it in a loop to open multiple workbooks, but that is not the case.
With the line that the debugger highlights:
Set wbData = Workbook.Open("Filename as String", ,"Read only")
The Filename in your code is set as follows:
bLauncher.Worksheets("config").Cells(Worksheets("config").Range("Program1").Row - 1 + shtActive.Shapes(1).ControlFormat.ListIndex, Worksheets("config").Range("Program1").Column)
The Code refers to a worksheet called "Config". On this worksheet a cell is referred to by the
Cells(Rowindex, Columnindex)
The Row- and Columnindex are numbers which refer to the rownumber and column the cell is on. e.g. cell A2 is Cells(2, 1) cell E34 is ` Cells(34,5)
You're code is setting the Rowindex as follows
Worksheets("config").Range("Program1").Row - 1 + shtActive.Shapes(1).ControlFormat.ListIndex
This bit refers to a named range named "Pgrogam1" on the worksheet "Config" the .row returns the rownumber this range is on. 1 is then subtracted from this number and then the listindex of the selection is added to arrive at the cell which holds the filename which corresponds to the selection in the listbox.
Multiple selections in the listbox would mean that you're trying to open multiple cells and with your current code that is impossible, even under office 2007.