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)
Related
I really appreciate if someone here would help me crack this problem which i cant find the solution (and sorry for my bad english).
So i have multiple excels in one folder. every excel in it have same format 1st sheet for reference of every sheet, 2nd sheet for consolidation data, and 3rd sheet and the rest for the data to be consolidated. Every excel in the folder have various amount of sheet.
What i want to do is i want to copy data from range A27:AJ500 that begin from 3rd sheet to every sheet after, into another new workbook in sheet1 and paste it begin from cell A27 over and over into the bottom and looping for every excel in folder.
i dont have enough ability yet to write my own script but i managed to understand some and combine it into this script.
Sub Download_Data()
Path = "C:\Users\ASUS\Desktop\Done\"
Filename = Dir(Path & "*.xlsm")
'to open every excel in my folder
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True '--> i only managed to do it right till here
'supposed to copy range in every sheet of excel in my folder into different workbook
For Each ws In thiswoorkbook.Worksheets '--> i try write this code but i am confused to do what i want from here and i know this code is nowhere near true
With ws
If .Name <> "GABUNGAN" Then
range("A27:AJ500").Select
Selection.copy
Workbooks("Tes.xlsm").range("A27").PasteSpecial Paste:=xlPasteValues
End If
End With
Next ws
Workbooks(Filename).Close
Filename = Dir()
Loop
Application.Goto ActiveWorkbook.Sheets("sheet1").range("A1")
End Sub
I've been searching for the code not only i cant customize it to this code but also i cant understand what is wrong in the code therefore i write this question. Any help will be appreciated, thanks in advance for your attention wish you safe and sound.
Try this: (tested)
Dim sourcewb As Workbook
Dim destwb As Workbook
Dim y As Long
Dim ws As Worksheet
Dim strPath As String, strFilename As String
strPath = "C:\Users\ASUS\Desktop\Done\"
strFilename = Dir(strPath & "*.xlsm")
y = 27
Set destwb = ThisWorkbook
Do While strFilename <> ""
Set sourcewb = Workbooks.Open(Filename:=strPath & strFilename, ReadOnly:=True)
For Each ws In sourcewb.Worksheets
With ws
If .Name <> "name of reference sheet" And .Name <> "name of consolidation sheet" Then
.Range("A27:AJ500").Copy
destwb.Worksheets("sheet1").Range("A" & y).PasteSpecial Paste:=xlPasteValues
y = y + (500 - 27) + 1
End If
End With
Next ws
sourcewb.Close False
strFilename = Dir()
Loop
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"
Background:
I have two workbooks in the same directory with different sheets in each one of them.
I would like to open book2.xlsx, execute a VBA, to copy the whole content from "sheet1" in book1.xls. After this, the book1.xls should be closed automatically.
I have a code, which is moving the content next to a sheet, then I have to rename this sheet to the desired one. The problem with this is one is I the formulas in the other sheet will not work as desired. The code is as follows,
Sub XLVBACopyFiles()
Dim MonthlyWB As Variant
Dim FileName As String
FileName = ActiveWorkbook.Name
Path = ActiveWorkbook.Path & "\"
Application.DisplayAlerts = False
Application.EnableEvents = False
'Copy the sheet1 next to sheet2 in the current workbook
Application.Workbooks.Open (Path & "book1.xls")
Sheets(Array("sheet1")).Select
Sheets("sheet1").Activate
Sheets(Array("sheet1")).Move After:=Workbooks( _
FileName).Sheets("sheet2")
Application.EnableEvents = True
Application.DisplayAlerts = True
Workbooks(FileName).Save
' Workbooks(FileName).Close
End Sub
Any help with this would be highly appreciated.
If what you want , according to your comment above, is paste the content to "sheet2 itself", update the code above :
Application.Workbooks.Open (Path & "book1.xls")
Sheets(Array("sheet1")).Select
Sheets("sheet1").Activate
**Sheets(Array("sheet1")).Move After:=Workbooks( _
FileName).Sheets("sheet2")**
to
Application.Workbooks.Open (Path & "book1.xls")
Sheets(Array("sheet1")).Select
Sheets("sheet1").Activate
'Next 2 lines will select the range of content to be copied, and CTRL+C it. Edit it to your desire range
Range("A1:A5").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select ' In this line you should choose which cell to start pasting
ActiveSheet.Paste
Also, to close workbook, use:
Workbooks("book1.xls").Close SaveChanges:=True
Pay attention to SaveChanges option, choose True/False if you want to save or not this workbook
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.