Hi I have the following code to copy all worksheets of all workbooks in a given folder to a single workbook. I need to modify this code to copy only the active sheet on all workbooks (now it copies all the sheets). Can you help me with this?
Option Explicit
Sub CombineFiles()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\" 'Change as needed
FileName = Dir(Path & "\*.xlsx", 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
This way you can do what you want:
Option Explicit
Sub CombineFiles()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\" 'Change as needed
FileName = Dir(Path & "\*.xlsx", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
ActiveSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'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
Note:
When you open the workbook, you go over all the sheets with the FOR LOOP, but you only need to copy the ActiveSheet then (as you said) you only need to copy to the new Wrokbook
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!
I want to loop through all Workbooks in a folder and then loop through all worksheets of each workbook. I have the code below but currently the problem is with the line For Each ws in StrFile.Sheets:
Sub LoopThroughFiles()
Dim StrFile As String
StrFile = Dir("C:\Users\A9900899\Desktop\bob\VBAProject\Raw\")
Do While Len(StrFile) > 0
Debug.Print StrFile
For Each ws In StrFile.Sheets
Debug.Print ws.Name
Next ws
StrFile = Dir
Loop
End Sub
What is my mistake here?
In order to loop through all Workbook.Sheets you need to Set wb to the current StrFile, and then loop through wb.Sheets.
Using Application.ScreenUpdating = False and Application.DisplayAlerts = False will minimize all screen flickering and Excel alerts.
Code
Option Explicit
Sub LoopThroughFiles()
Dim StrFile As Variant
Dim fPath As String
Dim wb As Workbook
Dim ws As Worksheet
fPath = "C:\Users\A9900899\Desktop\bob\VBAProject\Raw\"
StrFile = Dir(fPath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While StrFile <> ""
Debug.Print StrFile
If StrFile Like "*xls*" Then ' check that current file is Excel type
Set wb = Workbooks.Open(fPath & StrFile)
For Each ws In wb.Sheets
Debug.Print ws.Name
Next ws
wb.Close False ' close workbook and don't save changes
End If
StrFile = Dir
Wend
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I am trying to merge many excel files (workbooks) from a folder.
My problem is that I want to move different sheets to the new excel file.
At the moment my code can only move one sheet at the time from these different files.
Example:
I have 3 excel files named
1.xlsx
2.xlsx
3.xlsx
all 3 files have 3 sheets in it and I want to take sheet1 from 1.xlsx and sheet1 and sheet2 from 2.xlsx and finally sheet3 from 3.xlsx and put in a new excel file.
My code at the moment can only takes one sheet (and same sheet number) from each file and put in the new file.
My code so fare:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=path & "\" & Filename)
sheet = 1
Set wsSrc = wbSrc.Worksheets(sheet)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Many thank in advance
You need to loop through all the Sheets in the current Workbook found in your folder.
Try the code below:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(Path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=Path & "\" & Filename)
Sheet = 1
' ****** you need to loop on all sheets per Excel workbook found in Folder ******
For Each wsSrc In wbSrc.Sheets
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
Next wsSrc
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I just started using VBA and I've been using a code to merge multiple worksheets into a single workbook, it works fine except for worksheets containing images. In these cases the image won't show in the new workbook created. It appears the box where the image should be with an error message. I use MS Office 2010.
Here follows the code I've been using:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Any idea of what is going on? I'd appreciate any help!
Tks!
just found a workaround that helped!
I just added "Application.ScreenUpdating = True" before closing the source workbook, it takes longer to merge all worsheets, but at least the images are displayed correctly!
Here follows the new code:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
**Application.ScreenUpdating = True**
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Found this workaround here - Option 1!
Tks Dan!
This is part of the sub I found to copy all tabs in all workbooks in a directory to my current workbook, but how can I adjust it to scan all subfolders as well? Currently, it only copies from the folder I select and then stops.
Here's the full code with functions: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls*", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
Using the code I posted in the linked question (untested)
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
Dim colFiles As New Collection, fPath
ThisWB = ThisWorkbook.path & "\" & ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
GetFiles path, "*.xls*", True, colFiles
For Each fPath In colFiles
If fPath <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=fPath)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
Next fPath
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
VBA macro that search for file in multiple subfolders