I have 2 different type of files. 1 is ".tsv" 2 is ".xlsx".
I want my macro (.xlsm) file to be in same folder where 2 different files (.tsv and .xlsx) are placed. I usually download them from some tools and normally they are placed in my default "Download" folder.
Problem 1: I want my macro file to read both format and copy paste data into single excel file. I am done with this problem. Code optimization is required.
Problem 2: I am currently assigning manual path to that folder and want macro to pick that folder path so that it can copy 2 extension files and proceed.
(Tried : ActiveWorkbook.Path, didn't work).
Dim FPath As String, filename As String, FileExt1 As String, FileExt2 As
String
Sub GetSheets()
FPath = "C:\Users\dinekuma\Desktop\Dinesh KT\Macro New UI\"
FileExt1 = "*.tsv"
FileExt2 = "*.xlsx"
'ActiveWorkbook.Path
'"C:\Users\dinekuma\Desktop\Dinesh KT\Macro New UI\"
filename = Dir(FPath & FileExt1)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While filename <> ""
Workbooks.Open filename:=FPath & filename, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = Split(filename, ".")(0)
Next sheet
Workbooks(filename).Close
filename = Dir()
Loop
filename = Dir(FPath & FileExt2)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While filename <> ""
Workbooks.Open filename:=FPath & filename, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = Split(filename, ".")(0)
Next sheet
Workbooks(filename).Close
filename = Dir()
Loop
MsgBox ("Import Successful!")
End Sub
Help in code optimization and automatic path pick by active macro file.
Related
I am looking to take multiple Excel workbooks (that each have 1 worksheet) and merge them in to one Workbook.
So currently I have 9 workbooks, each with 1 worksheet, I would like to end up with 1 workbook, with 9 worksheets.
This is the code I have been using:
Function MergeBooks(Path As String)
Set NewBook = Workbooks.Add
With NewBook
.Title = "Merged Data"
.Subject = "End User Data"
.SaveAs Filename:=Path & "mergedFinal.xlsx", FileFormat:=xlOpenXMLWorkbook
End With
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=NewBook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
NewBook.Save
End Function
In my mind it seems to follow the right steps, I plan to run this from PowerShell and so far it runs and makes the new file, and I can see it loop through the files in the folder, so these are being picked up fine. However, when going to copy the worksheet on line 15 it produces an error "out of memory". The final product workbook then ends up empty.
Any advice would be appreciated. Thanks
I'm trying to make a merge file script just as this question.
https://stackoverflow.com/a/4148797/1864883
It's working fine, it's copping the files into new worksheets inside the same new workbook.
The only problem is that the colours are not been the same in the target file.
Here is a screenshot comparing input and output:
Here is the macro that I'm running to accomplish the task:
Option Explicit
'Ref: https://stackoverflow.com/a/26474331/1864883
Private Sub MergeFiles()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String, currentFile As Workbook, thisFile As Workbook, output As Workbook, outputName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set thisFile = ActiveWorkbook 'Reference for current workbook
directory = thisFile.Sheets("teste1").Cells(2, 2).Value 'Get path of files to merge from cell B2
outputName = thisFile.Sheets("teste1").Cells(3, 2).Value 'Get output file name from cell B3
fileName = Dir(directory & "*.xl??")
Set output = Workbooks.Add 'Create new workbook for output
'Ref: https://stackoverflow.com/a/4148797/1864883
Do While fileName <> ""
Set currentFile = Workbooks.Open(directory & fileName) 'Open file as current file
WrdArray() = Split(fileName, ".") 'Split file name in `.` to get name without extension
For Each sheet In currentFile.Worksheets 'Interate each sheet
currentFile.ActiveSheet.Name = WrdArray(0) 'Changes sheet name to same as file name
sheetsInOutput = output.Worksheets.Count 'Amount of seets in output
currentFile.Worksheets(sheet.Name).Copy after:=output.Worksheets(sheetsInOutput)
GoTo exitFor:
Next sheet
exitFor:
currentFile.Close
fileName = Dir()
Loop
output.Worksheets(1).Delete 'Delete first sheet crated when output created
output.SaveAs fileName:=thisFile.Path & "\" & outputName 'Saves output in same directory as this file
output.Close 'closes output file
'thisFile.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Referência: https://stackoverflow.com/a/2051420/1864883
Private Sub Workbook_Open()
Call MergeFiles ' Call your macro
'ActiveWorkbook.Save ' Save the current workbook, bypassing the prompt
'Application.Quit ' Quit Excel
End Sub
PS: I tested with some other files that worked just fine, These file that I'm getting trouble are from Crystal Report.
Read this: https://msdn.microsoft.com/en-us/library/office/ff821660.aspx
You need make sure that both workbooks have same color.
Example:
ThisWorkbook.Colors = Workbooks(2).Colors
I have about 70 different excel files that I need to combine into one master workbook. I would like each excel file to get its own worksheet in the master workbook. The name of the worksheet generated in the master workbook doesn't matter.
I retrieved this code off of another website, but cannot make it work for my needs. This code stipulates that all files to be combined are located in the same directory. I have them located here "C:\Users\josiahh\Desktop\cf"
Below is the code as it is now
Sub GetSheets()
Path = "C:\Users\dt\Desktop\dt kte\"
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
This is tested and works as expected. You would be wise to use Option Explicit and declare your variables appropriately in the future, although that did not cause any problems with your code.
As indicated in comments above, the likely failure is that the argument you're passing to the Dir function is unnecessarily restrictive:
=Dir(path & "*.xls") will look ONLY for files ending exactly in ".xls", and will not account for newer file formats. To resolve that, do =Dir(path & "*.xls*")
Code below:
Option Explicit
Const path As String = "C:\Users\dt\Desktop\dt kte\"
Sub GetSheets()
Dim FileName As String
Dim wb As Workbook
Dim sheet As Worksheet
FileName = Dir(path & "*.xls*")
Do While FileName <> ""
Set wb = Workbooks.Open(FileName:=path & FileName, ReadOnly:=True)
For Each sheet In wb.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
wb.Close
FileName = Dir()
Loop
End Sub
I am trying to copy a worksheet called "application" from all identical files in a folder, into a master workbook and rename the copied worksheet in the name of the file its been copied from. So far my code copies everything and I cannot get it to rename the copied worksheet to name of file it came from.
Thank you
Sub GetSheets()
Application.ScreenUpdating = False
Path = "C:\Users\Desktop\Work docs\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Name = "application" Then
End If
Sheets.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close SaveChanges:=False
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Your IF condition is closing before you are copying 'application' sheet, so Sheets.Copy will just copy all the sheets from your workbook. You can try the below code:
Do While Filename <> ""
Workbooks.Open Filename:=Path1 & Filename, ReadOnly:=True
For Each Sheet In Workbooks(Filename).Sheets
If Sheet.Name = "application" Then
Sheet.Copy After:=ThisWorkbook.Sheets(1)
ThisWorkbook.Sheets("application").Name = Filename & "-application" 'Changes the sheetname from "application" of test1.xls workbook to "test1.xls-application"
End If
Next Sheet
Workbooks(Filename).Close SaveChanges:=False
Filename = Dir()
Loop
I was not able to use Path as a variable (maybe due to some system configuration - need to check why), so I have used Path1 instead. You can use ActiveWorkbook.Sheets also instead of Workbooks(Filename).Sheets. However I feel its better to reference a workbook by its name.
Hi I just embed this code into my vba macro, but how to change default directory when I use this macro.. for example when I click it is going to D:/myfolder
I found this code at google :
Sub Copy_ActiveSheet_2()
'Working in Excel 2000-2013
Dim fname As Variant
Dim NewWb As Workbook
Dim FileFormatValue As Long
'Check the Excel version
If Val(Application.Version) < 9 Then Exit Sub
If Val(Application.Version) < 12 Then
'Only choice in the "Save as type" dropdown is Excel files(xls)
'because the Excel version is 2000-2003
fname = Application.GetSaveAsFilename(InitialFileName:="", _
filefilter:="Excel Files (*.xls), *.xls", _
Title:="This example copies the ActiveSheet to a new workbook")
If fname <> False Then
'Copy the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'We use the 2000-2003 format xlWorkbookNormal here to save as xls
NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
Else
'Give the user the choice to save in 2000-2003 format or in one of the
'new formats. Use the "Save as type" dropdown to make a choice,Default =
'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
fname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _
" Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
" Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
" Excel 2000-2003 Workbook (*.xls), *.xls," & _
" Excel Binary Workbook (*.xlsb), *.xlsb", _
FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")
'Find the correct FileFormat that match the choice in the "Save as type" list
If fname <> False Then
Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
Case "xls": FileFormatValue = 56
Case "xlsx": FileFormatValue = 51
Case "xlsm": FileFormatValue = 52
Case "xlsb": FileFormatValue = 50
Case Else: FileFormatValue = 0
End Select
'Now we can create/Save the file with the xlFileFormat parameter
'value that match the file extension
If FileFormatValue = 0 Then
MsgBox "Sorry, unknown file extension"
Else
'Copies the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'Save the file in the format you choose in the "Save as type" dropdown
NewWb.SaveAs fname, FileFormat:= _
FileFormatValue, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
End If
End If
End Sub
Change this part of the code
fname = Application.GetSaveAsFilename(InitialFileName:=""
to include the default save path you would like
fname = Application.GetSaveAsFilename(InitialFileName:=""C:\My Documents\"
Make sure you leave the trailing backslash, otherwise a default file will be suggested with a filename equal to the the path you have provided eg.
fname = Application.GetSaveAsFilename(InitialFileName:=""C:\My Documents"
Will result in a dialog where the default file named "My Documents" is saved in the location "C:\"