Trying to get this VBA in Excel to open a specific folder to select excel files to merge, I seem to be going round in circles as usual.....
Sub mergeFiles()
'Merges all files in a folder to a main file.
'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As fileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet
Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.fileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True
numberOfFilesChosen = tempFileDialog.Show
'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count
'Open each workbook
Workbooks.Open tempFileDialog.SelectedItems(i)
Set sourceWorkbook = ActiveWorkbook
'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
Next tempWorkSheet
'Close the source workbook
sourceWorkbook.Close
Next i
End Sub
Any ideas on how to modify the code to use a specific path for a folder would be much appreciated.
Here's hoping
Please, try the next code:
Sub mergeFilesBis()
'Define variables:
Dim i As Integer, tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook, tempWorkSheet As Worksheet
Dim initialFolder As String
initialFolder = "C:\"
Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Allow the user to select multiple workbooks
With tempFileDialog
.AllowMultiSelect = True
.InitialFileName = initialFolder
If Not .Show = -1 Then Exit Sub
End With
'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.count
Set sourceWorkbook = Workbooks.Open(tempFileDialog.SelectedItems(i))
'Copy each worksheet to the end of the main workbook
For Each tempWorkSheet In sourceWorkbook.Worksheets
tempWorkSheet.Copy After:=mainWorkbook.sheets(mainWorkbook.Worksheets.count)
Next tempWorkSheet
'Close the source workbook
sourceWorkbook.Close
Next i
End Sub
Related
I'd like to copy a sheet with formulas to other workbooks, so it is important to have a general target, which I can use for other workbooks, as well, not just for one.
Here is my code:
Sub Macro1()
Windows("Filefromcopy.xls").Activate
Sheets("needtocopy").Select
Sheets("needtocopy").Copy Before:=Workbooks("target.xls").Sheets(1)
End Sub
Could you please give me some help?
Thanks!
I'd do it like this:
Sub Button1_Click()
Dim source_worksheet As Worksheet
Dim source_workbook As Workbook
Dim target_workbook As Workbook
Set source_workbook = ActiveWorkbook
Set target_workbook = Workbooks.Add()
Set source_worksheet = source_workbook.Sheets("needtocopy")
source_worksheet.Copy Before:=target_workbook.Sheets(1)
End Sub
This piece of code is a bit verbose but the purpose is to give you an idea where things are happening.
The selection of the target workbook is done on the Set target_workbook row. Here you can create a new workbook (like I'm doing it in this example), or open an existing workbook.
To open an exisiting workbook, replace the Set target_workbook row with this:
Set target_workbook = Workbooks.Open("target.xls")
At the end, you can add some saving and closing functionality as well:
target_workbook.Save
target_workbook.Close
To get a list of files in a folder you need to define an object with Dir (as described in this post: Loop through files in a folder using VBA?):
Sub Button1_Click()
Dim source_worksheet As Worksheet
Dim source_workbook As Workbook
Dim target_workbook As Workbook
Set source_workbook = ActiveWorkbook
Set source_worksheet = source_workbook.Sheets("needtocopy")
Dim file As Variant
Dim folder As String
folder = "C:\test\"
file = Dir(folder)
Application.DisplayAlerts = False
While (file <> "")
If InStr(file, "Allocation") <> 0 Then
Set target_workbook = Workbooks.Open(folder & file)
source_worksheet.Copy Before:=target_workbook.Sheets(1)
target_workbook.Save
target_workbook.Close
End If
file = Dir
Wend
Application.DisplayAlerts = True
End Sub
can someone please tell me why the data is not copying and pasting (or why it is copying and pasting blank data? Also is there a way to speed the automation?
Sub GetDataCopyPaste()
Dim wbTarget As Workbook 'where the data will be pasted
Dim wbSource As Workbook 'where the data will be copied
Dim StrName As String 'name of the source sheet
Application.ScreenUpdating = False 'these statements help performance by disabling the self titled in each, remeber to re-enable at end of code
Application.DisplayAlerts = False
Set wbTarget = ActiveWorkbook 'set to the current workbook
StrName = ActiveSheet.Name 'get active sheetname of workbook
Set wbSource = Workbooks.Open("C:\Users\jjordan\Desktop\Test Dir\Test File Test\metrics list.xlsx") 'opens Target workbook
Set wbTarget = Workbooks.Open("C:\Users\jjordan\Desktop\Test Dir\MASTER\Weekly Logbook - 2016.xlsm") 'opens Source workbook
wbSource.Sheets("IOS").Range("A1:E60").Value = wbTarget.Sheets("Sheet6").Range("A1:E60").Value 'copy & pastes source data onto Target workbook
wbTarget.Save 'save workbook
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This line is backwards
wbSource.Sheets("IOS").Range("A1:E60").Value = wbTarget.Sheets("Sheet6").Range("A1:E60").Value 'copy & pastes source data onto Target workbook
You need
wbTarget.Sheets("Sheet6").Range("A1:E60") = wbSource.Sheets("IOS").Range("A1:E60").value
I just tested and succeeded
Option Explicit
Sub test()
Dim myWB As Workbook
Set myWB = Workbooks.Open("C:\Users\raystafarian\Downloads\Book3.xlsx")
Dim yourWB As Workbook
Set yourWB = Workbooks.Open("C:\Users\raystafarian\Downloads\Book2.xlsm")
myWB.Sheets("Sheet1").Range("C1:C4").Value = yourWB.Sheets("Sheet1").Range("A1:A4").Value
End Sub
I have a folder with 100+ workbooks. These workbooks contain a range of data. For simplicity I will call the data range A1:D2, the range is located on Sheet1 of all 100+ workbooks.
I also have a Summary workbook.
I would like to place VBA code in the Summary workbook that loops through the folder, copying the range A1:D2 of each of the 100+ workbooks.
I would then like to paste the A1:D2 range from each workbook in to Sheet1 of the Summary workbook. Each paste will start on the next unused row.
I am stuck doing this via a manual process right now and it is driving me insane.
I do know some basic VBA coding however my problem is that I can't figure out how to loop it correctly, and I am stuck coding each individual workbook to open-->copy-->paste-->close. This was fine with 10-20 workbooks but now I am at 100+ and it is growing every week.
Thanks again,
Brian
I have something that does exactly what you are asking for, if you want to copy multiple workbooks I suggest creating a new worksheet to capture the workbook information onto a spreadsheet. Instructions below
Create a new worksheet and give it a name, in this case we'll call the sheet 'Control'
Create a new module in VBA and use the code below to operate the workbook copy
I have left a section out for you to write your code for the functions that you want to perform.
Sub WorkbookConsolidator()
Dim WB As Workbook, wb1 as workbook
Dim WBName as Range
Dim folderselect as Variant, wbA as Variant, wbB as Variant,
Dim I as long, J as long
Dim objFolder As Object, objFile As Object
Dim WBRange as String
'Set Core Variables and Open Folder containing workbooks.
Set WB = ThisWorkbook
Worksheets("Control").Activate
Set FolderSelect = Application.FileDialog(msoFileDialogFolderPicker)
FolderSelect.AllowMultiSelect = False
MsgBox ("Please Select the Folder containing your Workbooks")
FolderSelect.Show
WBRange = FolderSelect.SelectedItems(1)
Set objFolder = objFSO.GetFolder(FolderSelect.SelectedItems(1))
' Fill out File name Fields in Control Sheet
' The workbook names will be captured in Column B
' This allows allocation for up to 100 workbooks
For I = 1 To 100
For Each objFile In objFolder.files
If objFile = "" Then Exit For
Cells(I, 2) = objFile.Name ' Workbook Name
Cells(I, 3) = WBRange ' Workbook Path
I = I + 1
Next objFile
Next I
'Loop through the list of workbooks created in the 'Control' Directory, adjust the loop range as preferred
For J = 100 To 1 Step -1
With Workbooks(ThisWorkbook).Worksheets("Control")
BookLocation = .Range("C" & J).Value
BookName = .Range("B" & J).Value
End With
Set wb1 = Workbooks.Open(Booklocation & Bookname)
' Write your code here'
CleanUp:
wb1.Close SaveChanges:=False
Next J
End Sub()
`
Try this
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFile As Scripting.File
Dim oFolder
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets("Sheet1").[A1:D1].Copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets("Sheet1").Cells(x, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
End Sub
I have a macro that opens a spreadsheet from a specific folder and saves the output to a worksheet called Sheet1 in another workbook. The macro works if the file name is called "MyFile.xls" but i would like it to be able to run on any file name but it must have a "Book2" worksheet.
Here is my code:
Dim source As Workbook
Dim output As Workbook
Dim sourceSheet as WorkSheet
Dim outputSheet as WorkSheet
Dim file As String
file = "C:\Spreadsheets\MyFile.xls" 'I would like it to handle any files from any location'
Set output = ThisWorkBook
output.Activate
If Len(Dir$(file)) > 0 Then
Set source = workbooks.Open(file)
Set sourceSheet = source.Worksheets("Book2") 'Must only run if the sheet is called Book2'
Set outputSheet = output.Worksheets("Sheet1") 'Saves sheets into a new sheet called Sheet1'
End Sub
Is this what you are trying? (TRIED AND TESTED)
Sub Sample()
Dim source As Workbook, output As Workbook
Dim sourceSheet As Worksheet, outputSheet As Worksheet
Dim File
'~~> Show a dialog to open any excel file
File = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If File = False Then Exit Sub
Set output = ThisWorkbook
If Len(Dir$(File)) > 0 Then
Set source = Workbooks.Open(File)
'~~> Error check to see if the workbook has that sheet
On Error Resume Next
Set sourceSheet = source.Worksheets("Book2")
If Err.Number = 0 Then
Set outputSheet = output.Worksheets("Sheet1")
'
'~~> Rest of your code
'
Else
MsgBox "Not found"
source.Close SaveChanges:=False
End If
On Error GoTo 0
End If
End Sub
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