VBA: Run-Time Automation Error - "Code execution has been interrupted" - vba

I'm attempting to write a program to loop through a directory of excel files and copy a range into a "Master Workbook". When I run the program I am prompted with "Code execution has been interrupted". If I select continue the code will successfully run but then a "run-time error '-2147221080' Automation error" appears.
The line that causes the error is:
Set ws = wb.Worksheets("Project Log")
My question is, why is this line causing the error and or is there a way to bypass the error prompt so that my code will successfully run?
Sub FileCompiler()
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim ws as Worksheet
'set workbook in which data will be copied to
Set Masterwb = ActiveWorkbook
'declare path
'folderPath = "C:MyPath\"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
'compile directory data to master spreadsheet
Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Set ws = wb.Worksheets("Project Log")
ws.Range(ws.Cells(2, "C"), ws.Cells(2, "C")).Copy
Masterwb.Worksheets("Staging").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
ws.Range(ws.Cells(7, "A"), ws.Cells(Rows.Count, "K").End(xlUp)).Copy
Masterwb.Worksheets("Staging").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
wb.Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub

Dim Finfo As String
Dim FilterIndex As Long
Dim Title As String
Dim CopyBook As Workbook
Dim CopySheet As Worksheet
Dim ForecastFileName As Variant
Dim MasterSheet AS Worksheet
Set MasterSheet = ThisWorkbook.Worksheets("Yoursheetname")
'now you can always use master sheet after you set copybook
'Set up file filter
Finfo = "Excel Files (*.xls*),*.xls*"
'Set filter index to Excel Files by default in case more are added
FilterIndex = 1
' set Caption for dialogue box
Title = "Hey there!, select a file"
'get the Forecast Filename
ForecastFileName = Application.GetOpenFilename(Finfo, FilterIndex, Title)
'Change this according to what you need for workbook and worksheet names
Workbooks.Open (ForecastFileName)
Set CopyBook = ActiveWorkbook
Set CopySheet = CopyBook.Worksheets(1)
'Do your code, remember to close
CopyBook.Close savechanges:=False 'Not needed now
You might want to check for the ForecastFileName being False, that is when the users x's out, you will also want to do a little validation the wb sheet is in the right format by checking column headers ect or you will wind up crashing.

Related

Subscript out of Range VBA Printing

I have a script that will print everything in my "Downloads" folder, the VBA script did work until I added a bit of code to "Fit Columns to Width" so that I could see all data before it printed, now it says "Subscript out of range" once it opens the first file in the "Downloads" folder, I think this is because the "Sheet1" is never called "Sheet1" it is instead named the first 15 characters of the actual file name.
Is anybody able to offer any assistance?
The Bit I've just added:
Worksheets("Sheet1").Columns("A:H").AutoFit
My Full Code:
Dim wb As Workbook, ws As Worksheet
Dim FileName As String, Path As String
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Path = "C:\Users\Jonathan.mackell\Downloads\*.csv"
FileName = Dir(Path, vbNormal)
Do Until FileName = ""
Application.DisplayAlerts = False
Workbooks.Open Left(Path, Len(Path) - 5) & FileName
Worksheets("Sheet1").Columns("A:H").AutoFit
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
ws.PrintOut
Next
wb.Close
FileName = Dir()
Loop
End Sub
Any help appreciated!
set the wb variable when you open it instead of using activeworkbook, and include the sh variable instead of using activesheet, and put that in your loop, so you dont need to know the name.
Sub Test
Dim wb As Workbook, ws As Worksheet
Dim FileName As String, Path As String
Path = "C:\Users\Jonathan.mackell\Downloads\*.csv"
FileName = Dir(Path, vbNormal)
Do Until FileName = ""
Application.DisplayAlerts = False
Set wb = Workbooks.Open(Left(Path, Len(Path) - 5) & FileName)
For Each ws In wb.Worksheets
ws.Columns("A:H").AutoFit
ws.PrintOut
Next
wb.Close
FileName = Dir()
Loop
End Sub

Excel 2013 cannot find and open the file in ThisWorkbook directory

The following issue occured to me. I use MS Excel 2013.
With the macro below I tried to find those accounts (which meets the criteria "In scope", e.g. account 12345678), to copy them, to search in the same folder (where ThisWorkbook is), to find another excel file which has as name the number of account (e.g. "12345678.xlsx") and to open it.
After the proposed corrections below, my macro finds and opens the desired file. But now the problem is that no actions can be performed on it: copy, paste, etc.
Could you please help on this?
Sub FileFinder()
'Excel variables:
Dim RngS As Excel.Range
Dim wbResults As Workbook
'Go to the column with specific text
Worksheets("Accounts source data").Activate
X = 3
Y = 25
While Not IsEmpty(Sheets("Accounts source data").Cells(X, Y))
Sheets("Accounts source data").Cells(X, Y).Select
If ActiveCell = "In scope" Then
Sheets("Accounts source data").Cells(X, Y - 22).Select
'Copy the account in scope
Set RngS = Selection
Selection.Copy
'Search, in same directory where the file is located, the file with that account (file comes with account number as name)
sDir = Dir$(ThisWorkbook.Path & "\" & RngS & ".xlsx", vbNormal)
Set oWB = Workbooks.Open(ThisWorkbook.Path & "\" & sDir)
'Here is where my error occurs
'[Run-time error 5: Invalid procedure call or argument]
Sheet2.Cells("B27:B30").Copy
oWB.Close
End If
X = X + 1
Wend
End Sub
Try the code below, I have my explanation and questions for you in the code (as commnets):
Option Explicit
Sub FileFinder()
' Excel variables:
Dim wbResults As Workbook
Dim oWB As Workbook
Dim Sht As Worksheet
Dim RngS As Range
Dim sDir As String
Dim LastRow As Long
Dim i As Long, Col As Long
Col = 25
' set ThisWorkbook object
Set wbResults = ThisWorkbook
' set the worksheet object
Set Sht = Worksheets("Accounts source data")
With Sht
' find last row with data in Column "Y" (Col = 25)
LastRow = .Cells(.Rows.Count, 25).End(xlUp).Row
For i = 3 To LastRow
If .Cells(i, Col) = "In scope" Then
' Set the range directly, no need to use `Select` and `Selection`
Set RngS = .Cells(i, Col).Offset(, -22)
' Search, in same directory where the file is located, the file with that account (file comes with account number as name)
sDir = Dir$(ThisWorkbook.Path & "\" & RngS.Value & ".xlsx", vbNormal)
Set oWB = Workbooks.Open(ThisWorkbook.Path & "\" & sDir)
oWB.Worksheets("Report").Range("B27:B30").Copy
' *** Paste in ThisWorkbook, in my exmaple "Sheet2" <-- modify to your needs
wbResults.Worksheets("Sheet2").Range("C1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
oWB.Close SaveChanges:=False
' sDir = Dir$
' clear objects
Set RngS = Nothing
Set oWB = Nothing
End If
Next i
End With
End Sub

Excel Sheet Name Error

I'm using a VBA code to cycle through excel files in a directory and pull information from one worksheet and paste into a newly created worksheet. I'm also naming my new worksheets (in my destination file) by the name in one of the cells in the source file.
My code works for the first loop but fails/stops in the second loop (VBA points to an error in the Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname line. I need to loop through 75 of these files and I'm unsure of what's going on because it works correctly for the first file.
Thanks so much for the help!
Sub AddSummaryTables()
Dim Spath, Filename, Sheetname As String
Dim Source, Dest As Workbook
Dim WS As Worksheet
Set Dest = ThisWorkbook
Spath = InputBox("Enter File Source Path") & "\"
Filename = Dir(Spath & "*.xls*")
Do While Filename <> ""
Set Source = Workbooks.Open(Spath & Filename)
Sheetname = Source.Sheets("Summary").Range("B2").Text
MsgBox Sheetname
Dest.Sheets.Add(After:=Dest.Sheets(Dest.Sheets.Count)).Name = Sheetname
Source.Sheets("Summary").Range("A1:R150").Copy
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteValues
Dest.Worksheets(Sheetname).Range("A1").PasteSpecial xlPasteFormats
Dest.Worksheets(Sheetname).Range("A1:R150").WrapText = False
Dest.Worksheets(Sheetname).Rows.AutoFit
Dest.Worksheets(Sheetname).Columns.AutoFit
Source.Close SaveChanges:=False
Dest.Save
Filename = Dir()
Loop
End Sub
following Comintern's and Wyatt's suggestion you could try like follows
Option Explicit
Sub AddSummaryTables()
Dim sPath As String, fileName As String
Dim sourceWb As Workbook, destWb As Workbook
Dim sourceWs As Worksheet, destWs As Worksheet
Set destWb = ThisWorkbook
sPath = InputBox("Enter File Source Path") & "\"
fileName = Dir(sPath & "*.xls*")
Do While fileName <> ""
Set sourceWb = Workbooks.Open(sPath & fileName)
Set sourceWs = GetWorksheet(sourceWb, "Summary")
If Not sourceWs Is Nothing Then
Set destWs = SetWorksheet(destWb, sourceWs.Range("B2").Text)
sourceWs.Range("A1:R150").Copy
With destWs
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
.UsedRange.WrapText = False
.Rows.AutoFit
.Columns.AutoFit
End With
sourceWb.Close SaveChanges:=False
destWb.Save
End If
fileName = Dir()
Loop
End Sub
Function GetWorksheet(wb As Workbook, sheetName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = wb.Worksheets(sheetName)
On Error GoTo 0
End Function
Function SetWorksheet(wb As Workbook, sheetName As String) As Worksheet
Dim i As Integer
Do While Not GetWorksheet(wb, sheetName & IIf(i = 0, "", "-" & i)) Is Nothing
i = i + 1
Loop
With wb
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = sheetName & IIf(i = 0, "", "-" & Format(i, "000"))
Set SetWorksheet = .ActiveSheet
End With
End Function
where you make sure that
any opened workbook has a "Summary" worksheet
you name worksheets in your destination workbook such as not to have duplicates: if you happen to deal with say three worksheets named "Sheet5" then your destination workbook will have added worksheets "Sheet5", "Sheet5-001" and "Sheet5-002".
You're issue may be that when you are adding the sheet from the second workbook, it has the same name as the sheet from the first workbook. You could check if the sheet exists and add a number to it. The post below might help.
Test or check if sheet exists

Copy value from active sheet to new excel file

I have a work sheet named Final_Sheet, I want to create a button on that sheet and execute the following operation
Select Cell Range A1:D30 and pickup the values from cell only and create a new Excel file and paste the copied cell values into Sheet1 of created excel file. I am able to o this much, further I can't understand what to do can anybody please help me out?
Private Sub Button1_Click()
Dim rownum As Integer
Dim selection As Range
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
rownum = InputBox("Row No to Copy :", "OK")
selection = ActiveSheet.Range(Cells(1, 1), Cells(rownum, 10)).Select
selection.Copy
Flname = InputBox("Enter File Name :", "Creating New File...")
MsgBox ("Output File Created Successfully")
If Flname <> "" Then
Set NewWkbk = Workbooks.Add
ThisWorkbook.Sheets(1).Range("D1:D30").Copy Before:=NewWkbk.Sheets(1)
NewWkbk.Sheet(1).Select
Cells(1, 1).Activate
selection.PasteSpecial xlPasteValues
NewWkbk.SaveAs ThisWorkbook.Path & "\" & Flname
ActiveWorkbook.Close
End If
End Sub
The code below should do as you've asked.
EDIT: Pastes values only
Private Sub Button1_Click()
'Dim Variables
Dim ws As Worksheet
Dim rng As Range
Dim wbNew As Workbook, wbCurrent As Workbook
Dim strFileName As String
'Assign object variables
Set wbCurrent = ActiveWorkbook
Set ws = wbCurrent.ActiveSheet
Set rng = ws.Range("A1:D30") 'Amend range if needed
'Get desired file path from user
strFileName = InputBox("Enter File Name: ", "Creating New File...")
If strFileName <> "" Then
'Create new Workbook and paste rng into it
Set wbNew = Workbooks.Add
rng.Copy
wbNew.Sheets(1).Range("A1:D30").PasteSpecial xlValues
'Save new workbook using desired filepath
wbNew.SaveAs wbCurrent.Path & "\" & strFileName
End If
End Sub
It wasn't clear to me from the question which workbook you wished to close with ActiveWorkbook.Close but you could easily add wbNew.Close or wbCurrent.Close below wbNew.SaveAs ... as required.

How to copy and append cells content from a different workbook to an Activework?

I have a macro that allows a user to browse and select multiple Excel files, after the user has selected the multiple Excel files, the content from multiple Excel files should be saved on the current active workbook, on one sheet. the content would be append one another.
The problem is that when the loop runs for the second time it complains with the range, it says the range should start at "A1".
here is my code below.
Sub Button3_Click()
Dim fileStr As Variant
Dim incount As Integer
Dim wbk1 As Workbook, wbk2 As Workbook
incount = 1
fileStr = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(fileStr)
MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))
Set wbk1 = ActiveWorkbook
Set wbk2 = Workbooks.Open(fileStr(i))
wbk2.Sheets(1).Cells.Copy wbk1.Worksheets("Sheet3").Cells(incount, 1)
incount = Range("A" & Rows.Count).End(xlUp).Row
wbk2.Close
Next i
MsgBox incount
End Sub
Function GetFileName(fileStr As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(fileStr)
End Function
Error message:
Run-time error '1004'
To paste all cells from an Excel worksheet into the current worksheet,
you must paste into the first cell(A1 or R1C1)
The cells.copy copies the whole sheet of data to the row of 'incount' which means that there is not room on the destination for the 'whole source sheet' below the already pasted data
Try the following code which removes incount and just picks up the UsedRange:
Sub Button3_Click()
Dim fileStr As Variant
Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet
fileStr = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
Set wbk1 = ActiveWorkbook
Set ws1 = wbk1.Sheets("Sheet3")
For i = 1 To UBound(fileStr)
MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))
Set wbk2 = Workbooks.Open(fileStr(i))
wbk2.Sheets(1).UsedRange.Copy ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 1, 1)
wbk2.Close
Next i
End Sub
Function GetFileName(fileStr As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(fileStr)
End Function