VBA Opening workbook error - vba

I have a VB form in Access 2010, that opens a file dialog box to make a excel selection. I send the file path as string to my variable: directory (directory = strPath) to open the workbook and copy its contents to my current workbook. Which works fine if you intend to use the tool once. It's when you import one file, then another that's in the same directory the error occurs.
Non-working Example:
Selected C:\Desktop\File1.xls, Import
Selected C:\Desktop\File2.xls, Import
Error:
Run-time error '1004':
A document with the name 'Tool.xlsm' is already open. You cannot open two documents with the same name, even if the documents are in different folders. To open the second document, either close the document that's currently open, or rename one of the documents.
Working Example (Separate Folders):
Selected C:\Desktop\File1.xls, Import
Selected C:\Desktop\TestFolder\File2.xls, Import
Public Sub CommandButton1_Click()
Dim intChoice As Integer
Dim strPath As String
Application.EnableCancelKey = xlDisabled
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to sheet 1
TextBox1 = strPath
End If
End Sub
Public Sub CommandButton2_Click()
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = strPath
FileName = Dir(directory & "*.xls")
Do While FileName <> ""
Workbooks.Open (directory & FileName)
For Each sheet In Workbooks(FileName).Worksheets
total = Workbooks("Tool.xlsm").Worksheets.Count
Workbooks(FileName).Worksheets(sheet.name).Copy _
after:=Workbooks("Tool.xlsm").Worksheets(total)
Next sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
End Sub
In DEBUG mode it doesn't like
Workbooks.Open (directory & FileName)
Any suggestions on a way to eliminate this error?

First, between directory and FileName, i assume there is a "\".
secondly, simply check if the workbook is already opened:
dim wb as workbook
err.clear
on error resume next
set wb = Workbooks (FileName) 'assuming the "\" is not in FileName
if err<>0 or Wb is nothing then 'either one works , you dont need to test both
err.clear
set wb= Workbooks.Open (directory & FileName)
end if
on error goto 0
if you don't use application.enableevents=false, your opened Wb will trigger its workbook_open events !

I wanted to post the working code, maybe it will help someone in the future. Thanks again to those who left comments.
This code will open a file dialog, allow the user to select 1 excel file then copy all sheets from the selected file into the current workbook.
Public Sub CommandButton1_Click()
Dim intChoice As Integer
Application.EnableCancelKey = xlDisabled
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to textbox1
TextBox1 = strPath
End If
End Sub
Public Sub CommandButton2_Click()
Dim directory As String, FileName As String, sheet As Worksheet, total As Integer
Dim wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Err.Clear
On Error Resume Next
Set wb = Workbooks(FileName) 'assuming the "\" is not in FileName
If Err <> 0 Or wb Is Nothing Then 'either one works , you dont need to test both
Err.Clear
Set wb = Workbooks.Open(directory & TextBox1)
End If
On Error GoTo 0
FileName = Dir(directory & TextBox1)
Do While FileName <> ""
Workbooks.Open (directory & TextBox1)
For Each sheet In Workbooks(FileName).Worksheets
total = Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets.Count
Workbooks(FileName).Worksheets(sheet.name).Copy _
after:=Workbooks("NAMEOFYOURWORKBOOK.xlsm").Worksheets(total)
Next sheet
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
End Sub

Related

Copy range from sheet, and loop through files in a directory and do the following, Add rows to specific sheet, and paste values into sheet

I need to copy data from one sheet on my desktop, and paste it to every xlsx file in a specified folder. The problem I am encountering is an endless loop of copy paste / adding rows.
paste_value is the value to be pasted in the specified range in the specified sheet " Exhibit 1d"
Below is the code
Sub loopFile()
Dim Filename, Pathname As String
Dim wb As Workbook
Dim paste_value As String
paste_value = Workbooks("copy_file.xlsx").Worksheets("EXHIBIT 1D").Range("B59:C64").Copy
Pathname = "C:\Users\GP8535\Desktop\loop_folder\"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
paste_value = Workbooks("copy_file.xlsx").Worksheets("EXHIBIT 1D").Range("B59:C64").Copy
Set wb = Workbooks.Open(Pathname & Filename)
wb.Worksheets("EXHIBIT 1D").Rows("57:63").EntireRow.Insert
wb.Worksheets("EXHIBIT 1D").Range("B59:C63").PasteSpecial
wb.Close SaveChanges:=True
Loop
End Sub
Try this. A few issues
your syntax for defining paste_value was wrong; I think better to define the range (using Set) and do this outside the loop as it doesn't change
key thing to loop through your files is the last line in the loop; your code would have opened the same workbook each time
don't forget to turn alerts and updating back on at the end
Sub loopFile()
Dim Filename, Pathname As String
Dim wb As Workbook
Dim paste_value As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Pathname = "C:\Users\GP8535\Desktop\loop_folder\"
Filename = Dir(Pathname & "\*.xls*")
Set paste_value = Workbooks("copy_file.xlsx").Worksheets("EXHIBIT 1D").Range("B59:C64")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
wb.Worksheets("EXHIBIT 1D").Rows("57:63").EntireRow.Insert
paste_value.Copy wb.Worksheets("EXHIBIT 1D").Range("B59:C63")
wb.Close SaveChanges:=True
Filename = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

excel VBA 1004 error when copying multiple tabs into one tab from a folder

I am getting a 1004 error when I try and combine workbook pages into one master document. The code works correctly on my device, but when I attempt to run the code on my friends device it throw a 1004 error. I believe he is on excel 2013, I am on excel 2016. Is there any way to convert my code into something that can be used on both devices?
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
wSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
Windows(sFname).Activate
Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)
wBk.Close False
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
This works correctly when I run it, prompts for the folder location, asks which files it should copy from (usually *), and then copies from specifically the worksheet name entered.
Realistically all I need is code that can extract one worksheet from several hundred excel files and combine them into one master document. being able to pick and choose which worksheets would just be a bonus.
Thank you!
Like Mat's Mug said, you should really validate you inputs.
Did your co-worker add a "\" at the end of the path? Does the Path even exist?
Test to make sure that the sheet exists in the file that you are copying from, with something like this:
Function SheetExists(Name As String, Optional Workbook As Excel.Workbook = Nothing) As Boolean
If Workbook Is Nothing Then Set Workbook = ThisWorkbook.Application.ActiveWorkbook
On Error Resume Next
If Workbook.Worksheets(Name).Name <> vbNullString Then
End If
If Err.Number = 0 Then SheetExists = True
On Error GoTo 0
End Function
Here is your code with the noted changes:
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim sSht As String
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
'Use the FolderPicker to verify the path
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then sPath = .SelectedItems(1)
End With
'ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
sSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
'Windows(sFname).Activate
If SheetExists(sSht, wBk) Then
wBk.Sheets(sSht).Copy Before:=ThisWorkbook.Sheets(1)
End If
wBk.Close False
sFname = Dir()
Loop
'ActiveWorkbook.Save
ThisWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The bigger question is, are the Sheets the same size? Old .xls files only have 65536 rows, where 2007+ .xlsx files go up to 1048576 rows.
You can't mix the two different worksheets. In that case, you need to copy all of the cells from one sheet to the other.
wBk.Sheets(sSht).Cells.Copy
ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Sheets(1)
ThisWorkbook.Sheets(1).Paste

How to copy a single tab from a workbook into a master workbook using VBA on excel

I'm trying to pull one tab into a master workbook from a number of workbooks in a specified folder. so far this is what I have:
Sub GetSheets()
Path = "D:\APQP\APQP\Open Projects\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheets("5-Phase").Select
Sheets("5-Phase").Copy Before:=ThisWorkbook.Sheets(1)
Next
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Right now when I run it, it populates the master workbook with 50 of the tabs from the first wookbook in the folder instead of coping the tab and moving on to the next workbook and coping the tab in that workbook. Any help would be great.
You have two major problems with your code. The For loop is unnecessary and you aren't working with the opened workbook. Something like this should work for you:
Sub GetSheets()
Dim wb As Workbook
Dim sPath As String
Dim sFileName As String
Set wb = ThisWorkbook
sPath = "D:\APQP\APQP\Open Projects\"
sFileName = Dir(sPath & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Do While Len(sFileName) > 0
With Workbooks.Open(sPath & sFileName, ReadOnly:=True)
.Sheets("5-Phase").Copy Before:=wb.Sheets(1)
.Close False
End With
sFileName = Dir()
Loop
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Open multiple excel files with user form

Write a code in vba that, Calling user form of one excel file to all the other 10 excel files without having any reference in those 10 excel files.
It is displaying the output in current excel file but not in the destination files and shows the error as Userform is already shown and showing form modally is not possible
Private Sub Workbook_OnClick()
Dim mypath As String
Dim file As Workbook
Dim wb As Workbook
Dim pat As String
Application.ScreenUpdating = False
ChDrive "C:"
ChDir "C:\Users\Administrator\Desktop\John"
'john is a folder on the desktop
mypath = Range("B1").Value
'mypath has the same value as chDir
file = Dir(mypath & "\" & "*.xlsx")
Set wb = Application.Workbooks.Open(file)
If (wb.Click) Then
Application.Visible = False
userform1.Show
End If
End Sub
chDir is mentioned because the default directory shown with the dir() function was C:\Users\Administrator\Documents\ but the folder saved in desktop and that is C:\Users\Administrators\Desktop\John
Sir, It is displaying the run time error - 91 that is "Object variable or with block variable is not set" and highlighting the line "file = Dir(mypath & "\" & "*.xlsx")"
Private Sub Workbook_OnClick()
Dim mypath As String
Dim file As String
Dim wb As Workbook
Dim pat As String
Application.ScreenUpdating = False
ChDrive "C:"
ChDir "C:\Users\Administrator\Desktop\John"
'john is a folder on the desktop
mypath = Range("B1").Value
'mypath has the same value as chDir
file = Dir(mypath & "\" & "*.xlsx")
Do While file <> ""
Set wb = Application.Workbooks.Open(file)
If Not IsEmpty(wb) Then
Application.Visible = False
userform1.Show
End If
wb.Close
file = Dir()
Loop
End Sub

Subscript out of range when copying worksheet

I would like to create a command button which imports the selected file into the current workbook.
I'm getting Subscript out of range error and I cannot find out the solution.
Here is what I have:
Private Sub CmdBrowseFile_Click()
Dim intChoice, total As Integer
Dim file, ControlFile As String
ControlFile = ActiveWorkbook.Name
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'Remove all other filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
'Add a custom filter
Call Application.FileDialog(msoFileDialogOpen).Filters.Add( _
"Text Files Only", "*.xlsx")
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
file = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'open file
Workbooks.Open fileName:=file
total = Workbooks(ControlFile).Worksheets.Count
Workbooks(file).Worksheets(ActiveSheet.Name).Copy _
after:=Workbooks(ControlFile).Worksheets(total)
Windows(file).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate
End If
Error :
The error occurs on the line
Workbooks(file).Worksheets(ActiveSheet.Name).Copy... because the Workbooks(<argument>) is expecting just the name of the file, without full path. You are parsing a full path.
Fixed code
Private Sub CmdBrowseFile_Click()
Dim intChoice As Integer, total As Integer 'note the correct declaring, for each variable As Type
Dim strFilePath As String, strControlFile As String
Dim strFileName As String
strControlFile = ActiveWorkbook.Name
'only allow the user to select one strFilePath
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'Remove all other filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
'Add a custom filter
Call Application.FileDialog(msoFileDialogOpen).Filters.Add( _
"Text Files Only", "*.xlsx")
'make the strFilePath dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the strFilePath path selected by the user
strFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'get the file name
strFileName = Dir(strFilePath)
'open strFilePath
Workbooks.Open fileName:=strFilePath
total = Workbooks(strControlFile).Worksheets.Count
Workbooks(strFileName).Worksheets(ActiveSheet.Name).Copy _
after:=Workbooks(strControlFile).Worksheets(total)
Windows(strFileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(strControlFile).Activate
End If
End Sub
Notes
The main change is the Dim strFileName As String and strFileName = Dir(strFilePath) and it's usage in the code after opening the new book. I changed the variables names for test purposes, I can read it more easily this way. You can use rename tool to revert the changes.