I have this vba code that puts sheet1 of all workbooks in a folder in as sheets in one workbook. This works all fine.
What I want to do is change the name of each sheet that is copied in to my workbook. Then I want to overwrite the files that already exists in the workbook.
Hope someone can help me with a solution.
Sub CombineFilesInSheets()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "*The path*" 'Change as needed
FileName = Dir(Path & "\*.xls", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
Worksheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
There are a couple ways to go about your request, and not to steal from /u/VBasic2008, but he's on a similar line of thinking to me.
'open workbook like you do
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
'perform your regular copy
Worksheets("Sheet1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'define a name
dim desiredSheetName as string
desiredSheetName = Wkb.Name 'takes the workbook name
'check if the desired name exists, and if so, delete the old sheet
If Not IsError(Evaluate(desiredSheetName & "!A1")) Then ThisWorkbook.Sheets(desiredSheetName).Delete
'name the last added sheet in ThisWorkbook the desired name
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = desiredSheetName
You could similarly use the check to do nothing if the desiredSheetName already exists, though I believe the above fits your post.
I fixed this by running a macro afterwards to delete and edit names of sheets
Related
I am trying to use VBA in order to automate a boring work process. I don't know the language so I copied a code from the internet which is as follows:
Problem statement: I have multiple excel files in one folder, from
them I have to extract a single sheet named "sheet 1" (all the files
have it, but sheet1 isn't the only sheet those workbooks have).
Then I have to paste them in a new workbook. (I don't mind
if each of them are in different sheet, because I'll just record a
macro to compile them later on)**
Does anyone have any suggestions?
Sub Combine_files()
Dim Path As String
Dim Filename As String
Dim Sheet As Worksheet
Path = "C:\Users\prayag.purohit\OneDrive\Desktop\Project KC\New folder\"
Filename = Dir(Path & "*.xlsx")
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
Below code takes the first sheet in every file and names the sheet to the filename.
Option Explicit
Sub Combine_files()
Dim Path As String, Filename As String
Dim wbFile As Workbook, wbActive As Workbook
Set wbActive = ActiveWorkbook
Path = "C:\Users\prayag.purohit\OneDrive\Desktop\Project KC\New folder\"
Filename = Dir(Path & "*.xlsx")
With Application
.ScreenUpdating = False
End With
Do While Filename <> ""
Set wbFile = Workbooks.Open(Path & Filename, False, True)
wbFile.Sheets(1).Copy After:=wbActive.Sheets(1)
wbActive.Sheets(2).Name = Filename
wbFile.Close SaveChanges:=False
Filename = Dir()
Loop
wbActive.Sheets(1).Select
With Application
.ScreenUpdating = True
End With
End Sub
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
I want to copy multiple sheets from one workbook(4 out of 14) but i'm starting with one("Data"). I want to rename the workbook based on a cell in the first workbook. with this code I get an "run-time error '1004' Excel cannot access the file 'C:\3B4DD....
my code so far:
Sub Newyeartest()
sheetstocopy = "data"
Worksheets(sheetstocopy).Copy
Dim FName As String
Dim FPath As String
FPath = "C:"
FName = Sheets("data").Range("A1") & ".xlsm"
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
End sub
If I delete the "Fileformat:=52" It seems to go better but I get a text that this file must be saved as an macro enabled file. But I would guess that "Xlsm" is macro enabled?
Instead of copying worksheets, the better way is to copy the workbook with all the worksheets and then delete the ones that are not needed.
The code saves the workbook first, using the path of the current workbook;
Then it starts checking every worksheet, making sure that the name is not "data";
If the name is not "data" and there are more than 1 worksheets left, it deletes the worksheet;
The Application.DisplayAlerts = False is needed, in order to remove the msgbox for confirmation of the deletion of the worksheet. Then the Alerts are back set to True;
If the name is not "data" and this is the last worksheet, it gives a MsgBox "Last worksheet cannot be deleted!", as far as a workbook should always have at least 1 worksheet, by design;
Sub NewTest()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\new.xlsm"
Dim sheetToCopy As String: sheetToCopy = "data"
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> sheetToCopy Then
If ThisWorkbook.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wks.Name).Delete
Application.DisplayAlerts = True
Else
MsgBox "Last worksheet cannot be deleted!"
End If
End If
Next wks
End Sub
This should do the trick:
Option Explicit
Sub Newyeartest()
Dim wb As Workbook
Dim SheetNames As Variant, Key As Variant
Dim FName As String, FPath As String
Application.ScreenUpdating = False
SheetNames = Array("data", "data2", "data3", "data4") 'store the sheet names you want to copy
Set wb = Workbooks.Add 'set a workbook variable which will create a new workbook
'loop through the sheets you previously stored to copy them
For Each Key In SheetNames
ThisWorkbook.Sheets(Key).Copy After:=wb.Sheets(wb.Sheets.Count)
Next Key
'delete the first sheet on the new created workbook
Application.DisplayAlerts = False
wb.Sheets(1).Delete
FPath = "C:\Test"
FName = ThisWorkbook.Sheets("data").Range("A1") & ".xlsm"
wb.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You cannot save directly to C:\ so you need to create a folder and the code will work.
I know similar questions have been asked, but I've tried all the solution codes with no success. I'm a beginner in VBA and What I'm trying to accomplish is:
Copy files from sfol to dfol
For each file now in dfol, if "summary" tab exists, change cell I3
For each file in dfol, if "sheet2" tab exists, change pivot filter
The code runs and the changes are complete for the first file in dfol, but it doesn't even open each of the rest of the files. I need it to open every file. Also as a side note, the final msgbox at the end does not pop-up, so I'm thinking the code doesn't even run its full course.
Sub GenerateReports()
'Generate Seed Run Validation Reports Macro
Dim wb As Workbook
Dim MainFile, dfol, sfol As String
Dim vDate, Fname, myExtension As String
Dim wsCount As Integer
Dim fso
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Confirm the user wants to proceed
If MsgBox("Compile?", vbYesNo) = vbNo Then Exit Sub
'Define current workbook
MainFile = ThisWorkbook.Name
'Define Dates
vDate = "Potato"
'Set file path
sfol = "I:\ABCFolder"
dfol = "I:\DEFFolder"
'Copy all files from source folder
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFolder sfol, dfol
'Target Path with extension
myExtension = "*.xls*"
dfol = dfol & "\"
Fname = Dir(dfol & myExtension)
'Loop through files in folder
Do While Fname <> ""
Set wb = Workbooks.Open(fileName:=dfol & Fname)
'Ensure workbook opened
DoEvents
wsCount = wb.Worksheets.Count
For i = 1 To wsCount
'Update Date on Summary tab
If wb.Worksheets(i).Name = "Summary" Then
wb.Worksheets(i).Range("I3") = vDate
End If
Next i
'save changes and close
wb.Close SaveChanges:=True
'Ensure workbook closed
DoEvents
'Get next file name
Fname = Dir
Loop
'***************************** End of Macro ***************************
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox ("Assumptions Compiled!")
End Sub
Additional problems:
Every time a file is opened, I get asked if I want to update the links. I need it just not update.
I will also need to rename all the files in the folder starting with "2017..." to be, say, "2018..."
Any help is greatly appreciated!
You can specify not to update links when opening.
Set wb = Workbooks.Open(fileName:=dfol & Fname, UpdateLinks:=false)
Use SaveAs to change the name of the open workbook.
wb.saveas FileName:=replace(wb.name, "2017", "2018")
After the SaveAs, wb will be the new copy of the original.
Use on error resume next for a more direct route to changing data on the Summary worksheet.
on error resume next
with wb.worksheets("summary")
.Range("I3") = vDate
end with
on error goto 0
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