I need to write a macro that allows me to select which workbook sheets I want to save as a new file separately.
I am currently doing it with the following code, but it saves all the sheets as a new file. I would like to be able to select or define which sheets I want to save.
Sub Save_sheets_xlsx()
Dim Path As String
Path = Application.ActiveWorkbook.Path
Dim FileName As String
FileName = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs FileName:=Path & "\" & FileName & " " & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Export Sheets As New Workbooks
Option Explicit
Sub ExportSheets()
Const SheetNameList As String = "Sheet1,Sheet2,Sheet3" ' commas no spaces!
Dim SheetNames() As String: SheetNames = Split(SheetNameList, ",")
Dim FolderPath As String: FolderPath = ThisWorkbook.Path
Dim BaseName As String
BaseName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
Application.ScreenUpdating = False
Dim sh As Object
Dim FilePath As String
For Each sh In ThisWorkbook.Sheets(SheetNames)
sh.Copy
FilePath = FolderPath & "\" & BaseName & " " & sh.Name & ".xlsx"
Application.DisplayAlerts = False ' overwrite without confirmation
Workbooks(Workbooks.Count).SaveAs FileName:=FilePath
Application.DisplayAlerts = True
Application.ActiveWorkbook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
MsgBox "Sheets exported.", vbInformation
End Sub
I recently asked about saving an excel file with a specific name to a set location:
Getting correct default save name and save directory with spaces in VBA
I want to use this same procedure but in a somewhat different way. I tried to edit the code to make it work, but I keep on have a black filename screen when I execute the code.
The file I want to save with the routine is a template which is being refreshed with new data every 4 weeks. It is a read-only file which functions as a source template and after updating the data, I has to be saved on a different location to keep the original source file save from errors/unwanted modification.
When refreshing, the template opens a file which contains the refresh script named "refresh_segment_template.xlsm".
the code in the template is:
Option Explicit
Dim aantalrijen As Long
Const SheetSchaduwblad As String = "schaduwblad"
-------
Sub vernieuwalles()
Dim myTemplate As String: myTemplate = ActiveWorkbook.Name
Dim myTool As String: myTool = "refresh_segment_template.xlsm"
Application.ScreenUpdating = False
Workbooks.Open GetPath & myTool
Application.Run myTool & "!vernieuwalles", myTemplate
Call Windows(myTool).Close(False)
Application.ScreenUpdating = True
End Sub
Private Function GetPath() As String
Dim myPosition As Integer
Dim myPath As String: myPath = ActiveWorkbook.Path
myPosition = InStr(StrReverse(myPath), "\") - 1
myPosition = Len(myPath) - myPosition
GetPath = Mid(myPath, 1, myPosition - 1) & "\XLAM\"
End Function
the code in the refresh_segment_template is:
Option Explicit
Dim aantalrijen As Long
Const SheetSchaduwblad As String = "schaduwblad"
------------------
Sub vernieuwalles(mytemplate As String)
Windows(mytemplate).Activate
On Error GoTo Err_
Application.StatusBar = "Bezig met vernieuwen"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Call SheetOpschonen
Call datawissen
Call dataplaatsen
Call kolomtitels
Call toevoegen
Call maaktabel
Call refreshpivots
Exit_:
Application.StatusBar = ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
Err_:
Call MsgBox(Err.Number & vbCrLf & Err.Description)
Resume Exit_
Application.Calculation = xlCalculationAutomatic
End Sub
-------------
Sub refreshpivots()
Dim workbook_Name As Variant
Dim location As String
Dim filename As String
filename = "M:\Commercie\Marktdata\IRi\Segment Ontwikkeling\" & ActiveWorkbook.Name
ActiveWorkbook.RefreshAll
workbook_Name = Application.GetSaveAsFilename(fileFilter:="Excel binary sheet (*.xlsb), *.xlsb", InitialFileName:="M:\Commercie\Marktdata\IRi\Segment Ontwikkeling\")
If workbook_Name <> False Then
ActiveWorkbook.SaveAs filename:=filename, WriteResPassword:="TM", FileFormat:=50
End If
End Sub
I am now wondering how I can make the last script to use the filename of the template and save it on the give location in the script (i.e. M:\Commercie\Marktdata\IRi\Segment Ontwikkeling).
When I execute the code above, I get a 'save as' screen, but with no filename given, only the set directory is correct.
The refresh_segment_template is a .xlsm file. The template is a .xlsb file.
Hi I have drafted the below code, which use the DIR function to loop through all the files and rename them, however this is not carried out in alphabetical order
Can the below code be amended to ensure it is completed in alphabetical order.
Sub Rename_Files()
Dim name As String
Dim returnaname As String
returnName = ActiveWorkbook.name
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.EnableEvents = False
'On Error Resume Next
MyFolder = "G:\Corpdata\STRAT_Information\Open\1. Yot Data (Scoring)\34. Disproportionality Tool\201718 Tool\Local Level Tool\Database_Extract_Tools\Area Files Offences"
MyFile = Dir(MyFolder & "\*.xls")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
name = Left(ActiveWorkbook.name, Len(ActiveWorkbook.name) - 5)
name = name & ("_Offence")
ActiveWorkbook.SaveAs Filename:=name
Windows(returnName).Activate
MyFile = Dir$ 'goes to next entry
Loop
End Sub
I'm searching for a code to run the same macro on 200+ files in the same folder directory until the last file is complete.
The macro I have currently does this once I click a button
Refresh .CSV data connection (File Selection window pops up in
the directory, I select the file)
Refreshes Pivot Table
Deletes Specific Tabs
Saves Copy As in another Directory
I want to eliminate me clicking the RUN button 200+ times, and selecting the .CSV file. Would anyone happen to know of a code that could do this?
Current MACRO is:
Sub Load_Brand3()
' Load_Brand3 Macro
Sheets("Data").Select
Range("DATATable[[#Headers],[Datetime]]").Select
Selection.ListObject.TableObject.Refresh
Sheets("Brand Summary").Select
Range("A13").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
ActiveSheet.PivotTables("PivotTable1").PivotFields("Retailer.Name").ShowDetail _
= False
Sheets("Brand Summary").Select
Dim SavedCopy As Excel.Workbook
ActiveWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Workbooks.Open "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = ActiveWorkbook
With SavedCopy
ActiveWorkbook.Connections("BrandExport").Delete
Application.DisplayAlerts = False
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Sheets("Brand Summary").Select
Range("A1").Select
Application.DisplayAlerts = True
.Close True
End With
MsgBox ("Your File was saved.")
End Sub
This should be close. Just change MyPath to the correct directory and run ProcessFiles.
Sub ProcessFiles()
Const MyPath As String = "C:\Users\best buy\Data Files\*.csv"
Dim FileName As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
FileName = Dir(MyPath, vbDirectory)
Do While FileName <> ""
Load_BrandFile FileName
FileName = Dir()
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
Sub Load_BrandFile(FileName As String)
Dim SavedCopy As Workbook
Dim DATATable As ListObject
Dim PivotTable1 As PivotTable
ThisWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = Workbooks.Open("C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm")
With SavedCopy
Set DATATable = .Worksheets("Data").ListObjects("DATATable")
DATATable.Refresh
Set PivotTable1 = .Worksheets("Brand Summary").PivotTables("PivotTable1")
PivotTable1.PivotCache.Connection = FileName
PivotTable1.PivotFields("Retailer.Name").ShowDetail = False
.Connections("BrandExport").Delete
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Application.Goto Reference:=.Worksheets("Brand Summary").Range("A1"), scroll:=True
.Close True
End With
End Sub
Hopefully this sorts it for you.
Sub CycleFolder()
Dim folderSelect As FileDialog
Set folderSelect = Application.FileDialog(msoFileDialogFolderPicker)
With folderSelect
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
strItem = .SelectedItems(1)
End With
Files = Dir(strItem & "\")
While Files <> ""
'RUN FUNCTION HERE
'Uncomment next line to test iteration
'Debug.Print Files
Files = Dir
Wend
End Sub
I am writing a function to take all the worksheets labeled "STORE #01" and create separate files for reach store that contain two tabs:
1 - The same "Compare Depts" sheet which all files will have
2 - The unique sheet associated with that store
Files must be stored as Store_01_City.xls.
When I run the macro, I do not see any files created. Also, the workbook I am running the macro in is password protected but I have entered the password obviously.
Sub SplitBook()
Dim xPath As String
Dim FilePath As String
xPath = Application.ThisWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Worksheets
If InStr(xWs.Name, "Store") <> 0 Then
Dim WB As Workbook
Set WB = xWs.Application.Workbooks.Add
ThisWorkbook.Sheets("Compare Depts").Copy Before:=WB.Sheets(1)
Sheets(xWs.Name).Copy Before:=WB.Sheets(2)
FilePath = "\" & Left(xWs.Name, 5) & "_" & Right(xWs.Name, 2)
& "_" & Application.ThisWorkbook.VLookup(Right(xWs.Name, 2),
ThisWorkbook.Sheets("Table").Range(H3, K100), 4)
WB.SaveAs Filename:=xPath & FilePath & ".xls"
WB.Close SaveChanges:=False
Set WB = Nothing
End If
Next xWs
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I found a way to by-pass the password for the old Macro and modified it. This also works, but is much slower than your function #Thomas Inzina
Sub ProcessStoreDistribution()
Application.DisplayAlerts = False
For Each c In ThisWorkbook.Sheets("Table").Range("StoreList")
Process c
Next c
Application.DisplayAlerts = True
MsgBox prompt:="Process Completed"
End Sub
Sub Process(ByVal c As Integer)
Dim wb As Workbook
ThisWorkbook.Activate
StoreNum = WorksheetFunction.VLookup(c, Sheets("Table").Range("StoreTable"), 2)
StoreName = WorksheetFunction.Proper(WorksheetFunction.VLookup(c, Sheets("Table").Range("StoreTable"), 5))
myST = "STORE #" & Right(StoreNum, 2)
mySTN = WorksheetFunction.Substitute(WorksheetFunction.Substitute(ActiveWorkbook.FullName, "PPE", "(PPE"), ".xlsm", ") Store Distribution Files")
Application.DisplayAlerts = False
Sheets(Array("COMPARE DEPTS", myST)).Select
Sheets(Array("COMPARE DEPTS", myST)).Copy
Set wb = ActiveWorkbook
Sheets(Array("COMPARE DEPTS", myST)).Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("COMPARE DEPTS").Activate
Application.CutCopyMode = False
If Len(Dir(mySTN, vbDirectory)) = 0 Then
MkDir mySTN
End If
mySTN = mySTN & "\STORE_" & StoreNum & "_" & StoreName & ".xls"
wb.SaveAs Filename:=mySTN _
, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
ThisWorkbook.Activate
Application.DisplayAlerts = True
End Sub
Updated
File picker added to get the external workbook.
I had to add a parameter to the VLookup and cast Right(.Name, 2) to an int. Hopefully it's smooth sailing from here.
Option Explicit
Sub ProcessExternalWorkBook()
Dim ExternalFilePath As String, password As String
ExternalFilePath = GetExcelWorkBookPath
If Len(ExternalFilePath) Then
password = Application.InputBox(Prompt:="Enter Password applicable", Type:=2)
SplitBook ExternalFilePath, password
End If
End Sub
Function GetExcelWorkBookPath() As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select a Excel WorkBook"
.AllowMultiSelect = False
.InitialFileName = "Path"
.Filters.Clear
.Filters.Add "Excel WorkBooks", "*.xls, *.xlsx, *.xlsm, *.xlsb"
If .Show = -1 Then
GetExcelWorkBookPath = .SelectedItems(1)
End If
End With
End Function
Sub SplitBook(ExternalFilePath As String, Optional sPassword As String)
Dim FilePath As String
Dim wb As Workbook, wbSource As Workbook
Dim xWs As Worksheet
Dim Secured
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbSource = Application.Workbooks.Open(Filename:=ExternalFilePath, ReadOnly:=True, password:=sPassword)
For Each xWs In wbSource.Worksheets
If InStr(xWs.Name, "Store") <> 0 Then
Debug.Print xWs.Name & ": was processed"
FilePath = getNewFilePath(xWs)
If Len(FilePath) Then
Sheets(Array("Compare Depts", xWs.Name)).Copy
Set wb = ActiveWorkbook
wb.SaveAs Filename:=FilePath, _
FileFormat:=xlExcel8, password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close SaveChanges:=False
Else
MsgBox xWs.Name & " was not found by VLookup", vbInformation
End If
Else
Debug.Print xWs.Name & ": was skipped"
End If
Next xWs
Set wb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function getNewFilePath(xWs As Worksheet) As String
Dim s As String, sLookup As String
On Error Resume Next
With xWs
sLookup = WorksheetFunction.VLookup(CInt(Right(.Name, 2)), .Parent.Sheets("Table").Range("H3", "K100"), 4, False)
s = ThisWorkbook.Path & "\"
s = s & Left(.Name, 5) & "_" & Right(.Name, 2) & "_" & sLookup
If Err.Number = 0 Then getNewFilePath = s & ".xls"
End With
On Error GoTo 0
End Function
Function getCellValue(cell)
Dim s
s = cell.innerHTML
s = Replace(s, "<br>", "")
s = Replace(s, "<br />", "")
getCellValue = s
End Function