The problem in question centers around one workbook which contains all of my data and breakdowns spread across a ton of worksheets. I'm trying to get macros set up to copy select sheets to a new workbook. I think my biggest problem is getting the coding right for the destination workbook since the name includes a date string that changes each day. The code that I've got so far to just create the new workbook and close it is:
Sub NewReport()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyDate = Date
Dim dateStr As String
dateStr = Format(MyDate, "MM-DD-YY")
Set W = Application.Workbooks.Add
W.SaveAs Filename:="N:\PAR\" & "New Report Name" & " " & dateStr, FileFormat:=51
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ActiveWorkbook.Close True
End Sub
This works and does what I want in regards to creating the new document, naming it the way it should be named, and at the end closing it. What I need help with is that middle portion for copying specific sheets from the original workbook to this new one. What I was thinking was along the lines of:
With Workbooks("Original Workbook.xlsm")
.Sheets(Array("Sheet1", "Sheet2")).Copy_ Before:=Workbooks("destination.xls").Sheet1
Or at least some type of array to get exactly what I want to copy over. The biggest sticking point is getting the destination workbook path name correct. Any advice regarding individual pieces of this little project or on the whole is greatly appreciated. Thanks!
EDIT: I also need to point out that the new workbook being generated needs to be just plain old excel format (.xlsx). No macros, no security warning for automatic updating links or enabling macros, zip. Just a plain book of the sheets I tell it to put there.
Ok. I finally got it working now. Sheet names are carried over (otherwise I would have to go behind and rename them); it saves one copy to be sent and one copy to our archive folder; and the new workbooks don't get any popup about enabling macros or updating links. The code I finally settled on (which could probably be trimmed a little) is:
Sub Report()
Dim Wb1 As Workbook
Dim dateStr As String
Dim myDate As Date
Dim Links As Variant
Dim i As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "MM-DD-YYYY")
Wb1.Sheets(Array("Sheet1Name", "Sheet2Name", "etc."))Copy
With ActiveWorkbook
Links = .LinkSources(xlExcelLinks)
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
.BreakLink Links(i), xlLinkTypeExcelLinks
Next i
End If
End With
ActiveWorkbook.SaveAs Filename:="N:\" & "Report Name" & " " & dateStr, FileFormat:=51
ActiveWorkbook.SaveAs Filename:="N:\Report Archive\" & "Report Name" & " " & dateStr, FileFormat:=51
ActiveWorkbook.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Hope that'll help someone else with the same issue!
Your copy line should be
Workbooks("Original Workbook.xlsm").Sheets(Array("Sheet1", "Sheet2")).Copy _
Before:=W.Sheets(1)
You can make your code fully variable rather than harcoding "Orginal Workbook.xlsm" and the Sheet1 and Sheet2 names
If you use two Workbook variables then you can set the ActiveWorbook (ie the one currently selected in Excel) as the workbook to be copied (alternatively you can set it to a closed workbook, existing open named workbook, or the workbook that contains the code).
With a standard
Application.Workbooks.Add
you will get a new workbook with the number of sheets installed as per your default option (normnally 3 sheets)
By specifying
Application.Workbooks.Add(1)
a new workbook is created with only one sheet
And note I disabled macros by setting EnableEvents to False but it would be unusual to have application events running when creating workbooks
Then when copying the sheet use
Sheets(Array(Wb1.Sheets(1).Name, Wb1.Sheets(2).Name)).Copy
'rather than
Sheets(Array("Sheet1", "Sheet2")).Copy
to avoid hardcoding the sheet names to be copied. This code will copy the two leftmoast sheets irrespective of naming
Lastly the initial single sheet is removed leaving you with a new file with only the two copied sheets inside
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "MM-DD-YY")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name, Wb1.Sheets(2).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
Wb2.SaveAs Filename:="c:\test\" & "New Report Name" & " " & dateStr, FileFormat:=51
Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Related
I have a macro which creates a tab, named by a cell - every time I run the macro - this tab has different name. I have to save only this tab as a separate csv file.
For now I have the code below - it saves all 2 tabs to a specified location. I would be really grateful for any ideas how I can manage this !
Dim mySheet As Worksheet
Dim myPath As String
Application.DisplayAlerts = False
For Each mySheet In ActiveWorkbook.Worksheets
myPath = "\\F:\ABC\INPUT\"
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(mySheet.Index).Copy
ActiveWorkbook.SaveAs Filename:=myPath & mySheet.Name, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next mySheet
Application.DisplayAlerts = False
In your question, you mentioned "I have a macro which creates a tab, named by a cell", so I am assuming that the tab is created based on the value in that cell. If that is the case, you may simply read the value of that cell in a vba variable. Something like:
Dim tabName as string
tabName = sheets("SheetName").range("A1").value 'if the cell for creating the sheet is A1
Now, use this variable to rename the file generated. Like,
ThisWorkbook.Worksheets(tabName).Copy
ActiveWorkbook.SaveAs Filename:="F:\path\" & tabName & ".csv"
Really stuck with a macro I using at the moment. What I have at the moment is a marco that exports every worksheet into a separate workbook which is great.
My issue is I have columns linked to a another worksheet (“Mapping”) for data validations.
When I open the newly created workbooks the data validation links are all broken.
So I’m wondering is it possible to change this macro so when it exports each worksheet, it also exports the “Mapping” sheet into each of the newly created workbooks? Code I’m currently using below:
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs filename:="H:\2017\Macro\" & MainWorkBook.Sheets(Pointer).Name & ".xlsx" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = ""
End Sub
Having played around abit I think you can change
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
To
MainWorkBook.Sheets(Array(Pointer, "Mapping")).Copy After:=NewWorkBook.Sheets(1)
Which preserves the Data Validation
I have the following macro
(Macro than rename the sheet with the value of cell B4 and then create one workbook for each sheet.)
Sub RenameTabs()
'UpdatebyTony
For x = 1 To Sheets.Count
If Worksheets(x).Range("B4").Value <> "" Then
Sheets(x).Name = Worksheets(x).Range("B4").Value
End If
Next
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
But this means I have to go and copy the macro in each excel file and run it.
I would like to be able to run de macro and it open a dialog where it ask me to choose the excel file that I want to rename the sheets and separate? Is that possible?
I know very little about VBA
Get the path of the workbook you like to perform the macro from FileDialog. You can use
Application.FileDialog
https://msdn.microsoft.com/en-us/library/office/ff836226.aspx
Open the workbook and set a reference for it.
set wb =Application.Workbooks.Open(filepath)
On your current sub RenameTabs, replace Application.ActiveWorkbook, ThisWorkBook with wb. Also, you need to properly reference the Sheets, Worksheets, ... to wb. Alternatively, you should make it sure that wb is the ActiveWorkbook (wb.Activate) (you can break the code if you switch to another excel file when it is still processing)
I have been trying to find a quick solution to "merge" excel files, came across at least a dozen different codes, tried recording my own macro and modifying that (instead of a range of sheet names trying to select the lot etc.) none of worked anywhere near the way I wanted it to, most of them didn't work at all.
The context as follows:
I have a lot of files in a folder ("C:\Zoltan\TEST\"), most have multiple sheets. I want to copy
all the sheets that DO NOT HAVE "Mailing" in the sheet name
from all the files that DO NOT HAVE "Printing" in the file name
into one file ("C:\Zoltan\TEST.xlsx") keeping the sheets separate as they are in the source files
only if the sheet name already exist, I want to give it a date stamp (e.g. the sheet called "NTI UK (150)" from "E8795 NTI Mailing Order.XLSX" created on the 28th August 2105 to become "NTI UK (150) 20150828"
Below is as far as I got, which unfortunately doesn't seem to do anything. Currently I'm running the macro from the opened destination file (which is not much of an issue, I'm quite happy to have it that way). I'm also still missing the "Printing" exclusion (instead of the "Mailing" inclusion) in the FILE NAME and the whole date stamp bit, but those will be my next steps:
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wbk As Workbook
Dim wSht As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = "C:\Zoltan\TEST\"
ChDir sPath
sFname = "*Mailing*"
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
Do Until sFname = ""
Set wbk = Workbooks.Open(sFname)
Windows(sFname).Activate
For Each ws In Sheets
If Not ws.Name Like "*Mailing*" Then ws.Copy Before:=ThisWorkbook.Sheets(1)
wbk.Close False
sFname = Dir()
Next
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I hope I've drawn up the problem in a clear and easy to understand way, but just to be on the safe side, if I did this manually it would be the following:
Open the TEST file
Open a source file that does not have the word
"Printing" in the file name
Highlight all the sheets that do not
have "Mailing" in the sheet name (these are just forms, not data
sheets, I don't need them)
Right click and "Move or Copy", tick
"Create a copy", select TEST.xlsx and select Sheet1
Close source file and move on to the next one
Please note, if the above is pure butchery, that is due to my lack of sufficient VBA skills. I tend to look at other people's codes, or record macros, take them apart and then try to make sense of them and put them back together the way I want them to work.
Where do I go wrong? Is there an easier way to code this? NB. I'd much rather copy entire sheets than highlighting ranges within sheets and place those ranges into new sheets in the destination file, like most codes (that I have come across) would do.
Many thankZ
Is your code creating a copy of the sheets you find? You're not explaining exactly what is, or is not, happening. You do have your sFname = Dir() command in the wrong place... And I suggest just automatically setting the names rather than trying to see if a name exists...
The filename is easy enough, use the following within your do loop:
Set wbk = Workbooks.Open(sFname)
Windows(sFname).Activate
For Each ws In Sheets
If Not sFname Like "*printing*" Then
If Not ws.Name Like "*Mailing*" Then
ws.Copy Before:=ThisWorkbook.Sheets(1)
ThisWorkbook.Sheets(1).Name = ThisWorkbook.Sheets(1).Name + Format(Now(), "yyyyMMdd-hhmm")
End If
wbk.Close
End If
Next
sFname = Dir()
Some fixes:
Sub CombineSheets()
Const sPath As String = "C:\Zoltan\TEST\"
Dim sFname As String
Dim wbk As Workbook
Dim wSht As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
'sPath already has a trailing \ - don't add another...
sFname = Dir(sPath & "*Mailing*.xl*", vbNormal)
Do Until sFname = ""
'Dir only gives you the filename - use full path below
Set wbk = Workbooks.Open(sPath & sFname)
For Each wSht In wbk.WorkSheets
If Not wSht.Name Like "*Mailing*" Then
wSht.Copy Before:=ThisWorkbook.Sheets(1)
End If
Next
'moved these lines out of the sheets loop
wbk.Close False
sFname = Dir()
Loop
ThisWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I'm trying to merge multiple Excel files from one Folder into a new file. I've found a solution on the Internet, that is adding my files into an open one. I'm not really into VBA Excel, so I think it's a basic problem, but I can't do it, things I've tried haven't worked properly. I would like to change the following code to create a new file called "summary" in the "Path" and copy the Sheets into this new file, overwriting the file every time I do it and deleting the several source files after doing this.
Is there a possibility of merging all those files into one without opening everyone of it?
Sub GetSheets()
Path = "C:\Merging\"
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
Your code almost works as is, just needs a couple of slight tweaks. I also agree with #AnalystCave that if this is a repeating exercise, you may consider a more streamlined solution. But this will work for you.
EDIT: changed to deal with existing destination file -- if it exists and is open, then connect to it otherwise open it; then delete all sheets in the existing file to prepare for the copies
Option Explicit
Function IsSheetEmpty(sht As Worksheet) As Boolean
IsSheetEmpty = Application.WorksheetFunction.CountA(sht.Cells) = 0
End Function
Sub GetSheets()
Dim Path, Filename As String
Dim Sheet As Worksheet
Dim newBook As Workbook
Dim appSheets As Integer
Dim srcFile As String
Dim dstFile As String
Dim dstPath As String
Dim wasntAlreadyOpen As Boolean
Application.ScreenUpdating = False 'go faster by not waiting for display
'--- create a new workbook with only one worksheet
dstFile = "AllSheetsHere.xlsx"
dstPath = ActiveWorkbook.Path & "\" & dstFile
wasntAlreadyOpen = True
If Dir(dstPath) = "" Then
'--- the destination workbook does not (yet) exist, so create it
appSheets = Application.SheetsInNewWorkbook 'saves the default number of new sheets
Application.SheetsInNewWorkbook = 1 'force only one new sheet
Set newBook = Application.Workbooks.Add
newBook.SaveAs dstFile
Application.SheetsInNewWorkbook = appSheets 'restores the default number of new sheets
Else
'--- the destination workbook exists, so ...
On Error Resume Next
wasntAlreadyOpen = False
Set newBook = Workbooks(dstFile) 'connect if already open
If newBook Is Nothing Then
Set newBook = Workbooks.Open(dstPath) 'open if needed
wasntAlreadyOpen = True
End If
On Error GoTo 0
'--- make sure to delete any/all worksheets so we're only left
' with a single empty sheet named "Sheet1"
Application.DisplayAlerts = False 'we dont need to see the warning message
Do While newBook.Sheets.Count > 1
newBook.Sheets(newBook.Sheets.Count).Delete
Loop
newBook.Sheets(1).Name = "Sheet1"
newBook.Sheets(1).Cells.ClearContents
newBook.Sheets(1).Cells.ClearFormats
Application.DisplayAlerts = True 'turn alerts back on
End If
Path = "C:\Temp\"
Filename = Dir(Path & "*.xls?") 'add the ? to pick up *.xlsx and *.xlsm files
Do While Filename <> ""
srcFile = Path & Filename
Workbooks.Open Filename:=srcFile, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
'--- potentially check for blank sheets, or only sheets
' with specific data on them
If Not IsSheetEmpty(Sheet) Then
Sheet.Copy After:=newBook.Sheets(1)
End If
Next Sheet
Workbooks(Filename).Close (False) 'add False to close without saving
Kill srcFile 'deletes the file
Filename = Dir()
Loop
'--- delete the original empty worksheet and save the book
If newBook.Sheets.Count > 1 Then
newBook.Sheets(1).Delete
End If
newBook.Save
'--- leave it open if it was already open when we started
If wasntAlreadyOpen Then
newBook.Close
End If
Application.ScreenUpdating = True 're-enable screen updates
End Sub
Firstly, regardless of your solution you will still need to OPEN every Excel workbook if you want to merge all of them.
Secondly, I think you might want to rephrase your question to "Is there a possibility of merging all those files into one faster or in any easier way?"
From the level of Excel VBA there is really no other way then opening each Workbook within the same Application level. If this is a one-time exercise I would stick to the code you already have and bear with it.
However, if this is an exercise you will be doing repeatedly and need an efficient solution, your only option is resorting to the OpenXML format which does not require a heavyweight Excel process e.g. creating a C# solution using the ClosedXML library. This will definitely reduce the time needed to consolidate your workbooks.