Had a code that was able to apply protect workbook but didn't save after running a different sub routine. I'm trying to apply a macro to all xlsx files in a folder where I'm deleting two sheets and applying a protect workbook. When I run it without the sheet deletion, the code runs but it doesn't apply to any of the files inside the folder.
Sub LoopThroughFilesFolder()
Dim StrFile As String, wb As Workbook, ws As Worksheet
StrFile = Dir("C:\Users\user\Documents\Destroy\*.xlsx*")
Do While Len(StrFile) > 0
For Each ws In Worksheets
If ws.Name = "Summary Copying" Or ws.Name = "Sum Totals" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
ProtectBookStructure ThisWorkbook, "password"
StrFile = Dir
Loop
End Sub
Fixed with this code
Sub LoopThroughFilesFolder()
Dim myfile As String
Dim wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
myfile = Dir("C:\Users\user\Documents\Destroy\*.xlsx*")
Do While myfile <> ""
Set wb = Workbooks.Open(fileName:=myfile)
For Each ws In Worksheets
If ws.Name = "Summary Copying" Or ws.Name = "Sum Totals" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
ProtectBookStructure wb, "password"
wb.Close savechanges:=True
myfile = Dir
Loop
Application.ScreenUpdating = True
End Sub
I recommend you check out the link posted by #DecimalTurn as a comment to your question.
A solution for your problem may look like this:
Sub LoopThroughFilesFolder()
Dim strFile As String, wb As Workbook, ws As Worksheet
strFile = Dir("C:\Users\user\Documents\Destroy\*.xlsx")
Do While Len(strFile) > 0
'Open the workbooks like this:
Set wb = Application.Workbooks.Open(strFile, False, False)
'In the following, use the "wb" variable to do what you want for the
'opened workbook.
For Each ws In wb.Worksheets
If ws.name = "Summary Copying" Or ws.name = "Sum Totals" Then
Application.DisplayAlerts = False
ws.DELETE
Application.DisplayAlerts = True
End If
Next
ProtectBookStructure wb, "password"
'Save and close
wb.Close SaveChanges:=True
strFile = Dir
Loop
End Sub
This code may still not work depending on how ProtectBookStructure looks like or if any of the workbooks in the folder are already password protected.
Related
Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I was using a VBA code that splits each worksheet into separate files (see above) however the problem is all the worksheets in the original file rely on one worksheet that have dropdown list values. (ie. if the worksheets were: monday, tuesday, wednesday, thursday, friday, dropdown lists), so by using the below vba code the dropdowns for monday through fridays worksheets are not working. How can I alter this code so that a copy of the dropdown worksheet/tab carries over with each worksheet? Or is there another solutions so that I can keep the dropdown list values in each tab and be able to split the file?
this code only separates each worksheet individually, but I need each worksheet in the file to split with a copy of a dropdown list tab that is found in the original file
Export Worksheets With Additional Same Worksheet
Option Explicit
Sub ExportWorksheets()
Const CopyWithAll As String = "DropDown Lists"
Dim DoNotCopy() As Variant: DoNotCopy = Array(CopyWithAll) ' add more!?
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim FolderPath As String: FolderPath = wb.Path & Application.PathSeparator
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim wsName As String
For Each ws In wb.Worksheets
wsName = ws.Name
If IsError(Application.Match(wsName, DoNotCopy, 0)) Then
wb.Worksheets(Array(wsName, CopyWithAll)).Copy
With Workbooks(Workbooks.Count)
Application.DisplayAlerts = False ' overwrite, no confirmation
.SaveAs FolderPath & wsName
Application.DisplayAlerts = True
.Close False
End With
End If
Next ws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub
Sub MergeWorkbooks()
Dim Path As String
Dim FileName As String
Dim ws As Worksheet
Dim wb As Workbook
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\Users\Name\Documents\Data\"
FileName = Dir(Path & "\*.xls", vbNormal)
Do Until FileName = ""
Set wb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each ws In wb.Worksheets
ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
Next ws
wb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I have 2 workbooks in same directory. Workbook 1 contain sheet A only and Workbook 2 contains sheets B and C. How can I merge sheet A and sheet C to my current workbook?
Make sure you open your source workbooks and then use the Worksheet.Move method or the Worksheet.Copy method to move or copy them into your current workbook.
Dim SourceWb1 As Workbook
Set SourceWb1 = Workbooks.Open(FileName:="C:\Path\To\Your\workbook1.xls")
SourceWb1.Worksheets("Sheet A").Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Dim SourceWb2 As Workbook
Set SourceWb2 = Workbooks.Open(FileName:="C:\Path\To\Your\workbook2.xls")
SourceWb2.Worksheets("Sheet C").Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
If you used the .Move method make sure you don't forget to save your source workbooks:
SourceWb1.Close SaveChanges:=True
SourceWb2.Close SaveChanges:=True
If you used the .Copy method close them without saving:
SourceWb1.Close SaveChanges:=False
SourceWb2.Close SaveChanges:=False
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've got a workbook where I am creating a button that allows to save two specific sheets without formula's (the purpose being that the sheets are going to be send to partners and costumers). I would like the sheets to be saved in a single document somewhere on my computer, and still have the current "design" with colors, setup etc.
I've currently written this code, which does everything that I've described, except deleting the formulas...
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Hope you can help :-)
I have a sheet I use something similar for, I'll adjust the code a bit to work with your scenario. If you don't want the settings to change, delete the TurnOnFunctions & TurnOffFunctions subs.
This code will only break the links, not necessarily all the formulas. So if a formula references another spreadsheet it will be a static value; however, if it is a simple formula that stays within the spreadsheet it will stay that way.
Also add your workbook name to the respective area.
Sub NewWorkbooks()
'This will make seperate workbooks for each of the tabs listed
Dim wb As Workbook
Dim NewBook As Workbook
Dim ws As Worksheet
Call TurnOffFunctions
Set wb = ActiveWorkbook
For Each ws In Workbooks("YOUR WORKBOOK NAMR"). _
Worksheets(Array("frontpage", "mobile"))
ws.Copy
Set NewBook = ActiveWorkbook
With NewBook
Call break_links(NewBook)
.SaveAs Filename:="C:XXXX" & "NAME", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next
Call TurnOnFunctions
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
Private Sub TurnOffFunctions()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Private Sub TurnOnFunctions()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
You can use yours too with this mod (untested):
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
Call break_links ActiveWorkbook
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
I have made the following code for moving sheet from one WB to another New WB.
However I am experiencing errors.
Sub MoveSheets01()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Application.ScreenUpdating = False
Set oldwb = ActiveWorkbook
Set newWB = Application.Workbooks.Add
oldwb.Activate
For Each ws In oldwb.Sheets
If ws.Name <> "Input" And ws.Name <> "Output" Then
Application.DisplayAlerts = False
ws.Copy after:=newWB.Sheets(newWB.Sheets.Count)
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
oldwb.Save
newWB.Activate
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
End Sub
It generates a new WB.
But the moment I save either, the file crashes.
Try this. See comments, especially regarding the filename. Most likely you have too long filename. If error occurs - post a comment with error text.
Sub MoveSheets010()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Dim link As Variant
' switch this off for the whole sub
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set oldwb = ThisWorkbook
For Each ws In oldwb.Sheets
If ws.Name <> "Input" And ws.Name <> "List" _
And ws.Name <> "Temp" And ws.Name <> "Index Data" _
And ws.Name <> "Ratio's" And ws.Name <> "Total Returns Index" _
And ws.Name <> "India VIX" And ws.Name <> "Output" Then
' check whether newWB is assigned
If Not newWB Is Nothing Then
' if assigned - just add sheet there
ws.Move before:=newWB.Sheets(1)
Else
' if not assign - create new workbook by moving the sheet
' this creates new workbook with only one sheet
' so there will be no "Sheet1", "Sheet2", etc
ws.Move
' assign newWB
Set newWB = ActiveWorkbook
End If
End If
Next
Set ws = Nothing
' save new wb first to avoid message about links/references
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
' remove references from source wb and save it
With oldwb
If Not IsEmpty(.LinkSources(xlExcelLinks)) Then
For Each link In .LinkSources(xlExcelLinks)
.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
.Save
End With
' switch this on back
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub