I have code in VBA that copies worksheets with the same tab name from different workbooks into one workbook. The workbooks that the code pulls from is in one folder. The code is working fine in Excel 2010 however when I run it in Excel 2013, I get the following 1004 error message: "Sorry, we couldn't find ....xlsx. Is it possible it was moved, renamed or deleted." I'm not sure where to start troubleshooting. Has anyone run into this problem or have any ideas why it would be working fine in Excel 2010 and not Excel 2013? Thank you.
Sub CombineSheets()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = "PathName\Inputs"
ChDir sPath
sFname = "*"
sFname = Dir(sPath & "\" & sFname & ".xlsx*", vbNormal) <Code bombs here>
wSht = ("Risks")
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
Are you sure this code has previously worked?
If it did, then your application's default file path has probably changed. You can check this with Debug.Print Application.DefaultFilePath In any event, you'd be better off defining your full path name explicitly in your sPath variable.
If you want to pick up legacy Excel documents then the string in your Dir function could just be "*.xls*" (but that would also collect macro-enabled workbooks). I wonder if that was originally intended with the asterix in your code.
There's no need to activate the window, but you might want an error handling line to check whether the "Risks" sheet does exist in the workbook.
There's also some redundancy in your code, so the whole thing ought to work okay as given below:
Sub CombineSheets()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = "PathName\Inputs" 'make this a full path eg "C:\..."
sFname = Dir(sPath & "\" & "*.xls*", vbNormal)
Do Until sFname = ""
'skip if it's this workbook
If sFname <> ThisWorkbook.Name Then
Set wBk = Workbooks.Open(sPath & "\" & sFname)
'check a "Risks" sheet exists
Set wSht = Nothing
On Error Resume Next
Set wSht = wBk.Sheets("Risks")
On Error GoTo 0
If Not wSht Is Nothing Then
wSht.Copy Before:=ThisWorkbook.Sheets(1)
End If
wBk.Close False
End If
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Related
I know the question has been asked so many times already, and I have tried to use Google to search the interest but failed to find the correct code. ( Trust me, I am not a taker).
Anyway, the idea is to run a script to merge all Excel files (CAD,GBP,JPY,USD) into a new Excel file (tab shows name "CAD","GBP", "JPY","USD") in the current folder. I have written the following script to merge Excel files, but it does not even work.
Sub CombineWorkbooks()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "X:\PATH\TO\EXCEL\FILES"
FileName = Dir(Path & "\*.xls", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each WS In Wkb.Worksheets
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next WS
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
You only have one small mistake.
Change:
Wkb.Close False
To:
Wkb.Close SaveChanges:=False
Here's my full, tested and working solution:
Sub CombineWorkbooks()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "X:\PATH\TO\EXCEL\FILES"
FileName = Dir(Path & "\*.xls", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each WS In Wkb.Worksheets
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next WS
Wkb.Close SaveChanges:=False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
If this doesn't work for you, please give more detail about the results and/or errors. A list of the file names in the folder would also be helpful.
If this does work for you, please remember to mark this as your answer, so others will know you have your solution. Thanks!
Im using a macro to copy alot of sheets into one excel file. The macro is from an old project so it needs some tweaking. It looks like this:
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
What I need is a way to rename the sheets that I copy, insted of the sheetname from the original file, I would like it to be renamed into the filename, or add the filename to the sheetname.
Not commenting on your old-macro-code (I personally do not like Windows(sFname).Activate but as far as it works it's ok), this is what to do to change the sheet name:
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)
'add this line --v
ThisWorkbook.Sheets(1).Name = "stack" & Replace(Time, ":", "")
'this line is added --^
wBk.Close False
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Note that you would probably have an error, if you are looping too fast once you try to save more than one worksheet, because the name would be the same. Thus, it is a wise idea to introducec a counter for the name.
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
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
I want to cycle through all workbooks in a folder, extract worksheets named "Sheet Name", and save them as .csv files with the name of the file from which they originated. What's quick way to do this?
Example of vba function in question:
Sub Sheet_SaveAs()
Dim wb As Workbook
Sheets("Sheet Name").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.name, FileFormat:=xlCSV
'.Close False
End With
End Sub
Many thanks for looking
EDIT: Not a duplicate because I am working on extracting sheets from multiple workbooks, and not multiple worksheets from a single workbook.
EDIT2: thank you, everyone.
Something like this.
Change this path to suit your folder
strFolder = "c:\temp"
code
Sub LoopThroughFiles()
Dim Wb As Workbook
Dim ws As Worksheet
Dim strFolder As String
Dim strFile As String
strFolder = "c:\temp"
strFile = Dir(strFolder & "\*.xls*")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Do While Len(strFile) > 0
Set Wb = Workbooks.Open(strFolder & "\" & strFile)
Set ws = Nothing
On Error Resume Next
Set ws = Wb.Sheets("Sheet Name")
On Error GoTo 0
If Not ws Is Nothing Then ws.SaveAs Left$(Wb.FullName, InStrRev(Wb.FullName, ".")) & "csv", FileFormat:=xlCSV
Wb.Close False
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub