Copy Sheet1 of multiple workbooks to one new workbook - excel

I have 99 workbooks in a folder. I want to copy sheet1 from each into a new workbook. It doesn't matter what order as long as each workbook/sheet1 goes onto a new worksheet in the destination workbook.
I have written a code, and tried to sample other codes. No matter what it will only copy sheet1 of the first 10 workbooks.
How can this work on all the workbooks in the folder? My goal is to get the sheets together so I can merge certain cells into a summary sheet.
I put this code into a module on my destination workbook.
Sub combineWorkbooks()
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*.xls") Do While fileName <> ""
Workbooks.Open fileName:=Path & fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
fileName = Dir() Loop
End Sub

EDIT: this should prevent any issues trying to copy multiple sheets with the same name into the workbook.
Sub combineWorkbooks()
Dim Path, fileName, sheetNum As Long, sheetName As String
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*.xls")
Do While fileName <> ""
With Workbooks.Open(fileName:=Path & fileName, ReadOnly:=True)
sheetName = .Worksheets(1).Name
sheetNum = 1
'if a worksheet with the same name already exists, add
' an incrementing number until the name is unique
If WorksheetExists(sheetName) Then
Do While WorksheetExists(sheetName & sheetNum)
sheetNum = sheetNum + 1
Loop
.Worksheets(1).Name = sheetName & sheetNum 'rename if required
End If
'copy to end of sheets
.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close
End With
fileName = Dir()
Loop
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
If you're still getting only 10 files then maybe it's an issue with the file names/extensions?
Edit - try listing all of the files:
Dim Path, fileName
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*")
Do While fileName <> ""
Debug.Print fileName
fileName = Dir()
Loop
What output do you get?

It was a file name extension, as you thought.
I now have this working.
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:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0800-JJ0899" '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

Related

Merge specific sheets from mutiple excel file

Currently able to copy all sheets from multiple excel files into one excel using the below code. However, I want to copy all data only from specific sheets (name defined) from multiple excel sheets.
need help!
Current Macro Code:
Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
Path = "E:\Excel_Projects\mergertest\"
Filename = Dir(Path & "*missing *")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Here is one approach you can try. Copy all sheets to your workbook, then delete the unwanted sheets.
Sub ConslidateWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Application.ScreenUpdating = False
Path = "E:\Excel_Projects\mergertest\"
Filename = Dir(Path & "*missing *")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
'One approach is to delete the unwanted sheets, once everything is copied to this workbook.
Dim UnWantedSheets As New Collection
UnWantedSheets.Add "Sheet4" 'Add all unwanted sheet names to this collection
UnWantedSheets.Add "Sheet5"
UnWantedSheets.Add "Sheet1"
Dim thissht As Worksheet
For Each thissht In ThisWorkbook.Sheets
For Each sht In UnWantedSheets
If LCase(thissht.Name) = LCase(sht) Then
Application.DisplayAlerts = False
thissht.Delete
Application.DisplayAlerts = True
Exit For
End If
Next
Next
End Sub

Referencing Non-Active Workbook Using Macro in Personal Workbook

I have a macro that works in any Excel workbook but doesn't work once I place it in my PERSONAL.XLSB file. My goal is to take the tabs from all of the files in a folder on my desktop and copy them into the active file. I know the issue is that I am using This.Workbook as the location reference for the copied tabs but I don't know how else to reference the workbook I am trying to copy the tabs into. I don't want to reference a filepath for where to copy the tabs since this will be used by multiple people in multiple files. Any thoughts would be greatly appreciated.
Sub CombineWorkbooks()
Dim Path As Variant
Path = GetFolder(1) & "\"
Dim FileName As String
FileName = Dir(Path & "*.xl??")
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open Path & FileName
For Each ws In ActiveWorkbook.Sheets
ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next ws
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
If you define the file to a variable or activeworkbook it should work.
UPDATED as I think I slightly misunderstood the overall objective of macro but the concept is still the same. Let me know if this doesn't work.
Sub CombineWorkbooks()
Dim Path As Variant
Path = GetFolder(1) & "\"
Dim FileName As String
FileName = Dir(Path & "*.xl??")
Dim ws As Worksheet, wkBkToCopyTo As Workbook
Set wkBkToCopyTo = ActiveWorkbook 'assuming that you run this with the destination open.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open Path & FileName
For Each ws In ActiveWorkbook.Sheets
ws.Copy after:=wkBkToCopyTo.Worksheets(wkBkToCopyTo.Worksheets.Count)
Next ws
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
You could also try to find it based on its name:
'you could also use a loop to find it
For Each wkBkToCopyTo In Application.Workbooks
If InStr(1, wkBkToCopyTo.Name, "someNameof the workbook", vbTextCompare) > 0 Then
Exit For
End If
Next wkBkToCopyTo

Get sheetname while importing excel sheet?

I would like to get the sheetname after I imported it excel workbook.
Below I was able to get the file name and now I would like to get the sheetname from the excel files imported and place in cell "C2"
Sub GetSheets()
'Update Excel Junction.com
Path = "C:\Users\momo\Desktop\Miscellaneous Shipment Packing List\New folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Range("B2").Value = Filename
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Simply by adding two lines into your loop, you can add the sheetnames:
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
k = 1
For Each Sheet In ActiveWorkbook.Sheets
Cells(2, 2+k).Value = Sheet.Name
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Range("B2").Value = Filename
k = k + 1
Next Sheet
In this example, if your workbooks have several sheets, the sheets will be added in the cells C D E F etc...
Try,
option explicit
Sub GetSheets()
dim wb1 as workbook, sh as worksheet
dim filename as string, path as string
set wb1 = thisworkbook
Path = "C:\Users\momo\Desktop\Miscellaneous Shipment Packing List\New folder\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
with Workbooks.Open( Filename:=Path & Filename, ReadOnly:=True)
For Each sh In .workSheets
sh.Copy After:=wb1.workSheets(1)
wb1.worksheets(1).cells(rows.count, "B").end(xlup).offset(1,0) = Filename
wb1.worksheets(1).cells(rows.count, "B").end(xlup).offset(0,1) = sh.name
Next sh
.Close savechanges:=false
end with
Filename = Dir()
Loop
End Sub
The rows.count doesn't require a parent because wb1 is either an xls or xlsx and you are opening xls's (unless you are opening more than 65K workbooks).

Merge a list of excel files into a new excel book

I need to create a macro that merges a list of excel files in a directory.
The folder contains other files that I don't want to pick. So, I need to specify the list of files (such as, selecting all the files which name contains "02.08.xlsx").
This is my first time using VBA, so please take that into consideration.
I've tried some things, but I think I always get problems regarding the files selection.
Here's what I've tried so far, but not working:
Sub MergeWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim ListFilenames As Variant
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = CurDir()
ListFilenames = Array("*02.08.02.01*.xlsx", "*02.08.13.01*.xlsx")
For i = 1 To 2
Filename = Dir(FolderPath & ListFilenames(i))
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Next i
Application.ScreenUpdating = True
End Sub
The code is wouldb be like this.
Sub MergeWorkbooks()
Dim FolderPath As String
Dim Filename As String
Dim ListFilenames As Variant
Dim Sheet As Worksheet
Application.ScreenUpdating = False
FolderPath = CurDir()
ListFilenames = Array("*02.08.02.01*.xlsx", "*02.08.13.01*.xlsx")
For i = 0 To 1
Filename = Dir(FolderPath & "\" & ListFilenames(i))
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & "\" & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
Next i
Application.ScreenUpdating = True
End Sub
Use the AddIn from the link below.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
That will do what you want.

Copy data from multiple workbooks in a folder into one workbook paste special only value

I want to Copy all sheets of multiple workbooks within a folder into another single workbook. I found below code but do not know how to paste special only values to avoid unnecessary formatting.
Sub GetSheets()
Path = "C:\Users\mechee69\Download\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Try the code below, it will PasteSpecial only the Values, if you want you can extend to copy also the Formats.
Option Explicit
Sub GetSheets()
Dim Path As String, Filename As String
Dim WB As Workbook
Dim Sht As Worksheet, ShtDest As Worksheet
Path = "C:\Users\mechee69\Download\"
Filename = Dir(Path & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Filename <> ""
Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
For Each Sht In WB.Sheets
Set ShtDest = ThisWorkbook.Sheets.Add(After:=Sheets(1))
Sht.Cells.Copy
ShtDest.Name = Sht.Name '<-- might raise an error in case there are 2 sheets with the same name
ShtDest.Cells.PasteSpecial xlValues
Next Sht
WB.Close
Filename = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Resources