EXCEL ExportAsFixedFormat to save some sheets - excel

Good morning,
Sub pdfs()
Application.ScreenUpdating = False
Dim i As Integer
Dim nome_arquivo As String
For i = 5 To Sheets.Count
nome_arquivo = Sheets(i).Name
With Sheets(i)
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & nome_arquivo & ".xlsx"
End With
Next i
Application.ScreenUpdating = True
End Sub
How can I adapt to create Excel files (.xlsx) instead of pdf files?

I found this vba code to create excel files from sheet 5:
Sub excels()
Dim i As Integer
Dim name1 As String
For i = 5 To Sheets.Count
name1= Sheets(i).Name
Worksheets(i).Copy
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & name1 & ".xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next i
End Sub

Related

Select and save specific sheets as new workbook

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

Saving Workbook Files Created from VBA to Sharepoint

I am trying to use the code below to save Workbook files that are created from individual sheets in a secondary workbook into my department's SharePoint, but the files are not showing up after the macro has run. There are no errors showing up and when I tried running this macro in a folder on my desktop it saved all the files correctly. Any ideas as to why it just won't work when its in a SharePoint?
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
Dim theFilePath As String
MyFilePath$ = ActiveWorkbook.Path & "\"
For Each Sheet In ThisWorkbook.Worksheets
SheetName$ = Sheet.Name
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
theFilePath = MyFilePath & "FY 20-21 P Card Statements - " & SheetName
MkDir theFilePath
theFilePath = theFilePath & "/" & "February Statement 1.6.21-2.6.21"
MkDir theFilePath
With Sheet
.Select
.Copy
ActiveWorkbook.SaveAs Filename:=theFilePath & "/" & SheetName & " Feb-06.xlsx", FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
End With
.CutCopyMode = False
End With
Next Sheet
End Sub

I want to save a selection as a new workbook but if the workbook already exists i want to save as a new worksheet within the existing workbook instead

I'm still fairly new to this. I want to be able to do the following:
select a copy range
paste selection in a new workbook
save workbook in a folder with year value found in range H5 (if folder does not exists, create one)
save file as "title_month_year" values found in ranges A5,F5,H5 (but if file already exists save as new worksheet/tab)
So far I believe I have 1-3 covered and part of 4.
Option Explicit
Const MYPATH As String = "C:\USERS\3658\Desktop\"
Sub IfNewFolder()
Dim AuditYear As String
AuditYear = Range("H5").Value
'if a particular directory doesnt exists already then create folder.
If Len(Dir(MYPATH & AuditYear, vbDirectory)) = 0 Then
MkDir MYPATH & AuditYear
End If
End Sub
Sub SaveCustomizedCourse()
'copy and past selected data in a new workbook
Range("B8").End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1").Select
Selection.PasteSpecial xlPasteColumnWidths
Selection.PasteSpecial xlPasteFormats
'save selected data in a new workbook
Dim AuditMonth As String
Dim AuditYear As String
Dim AuditTitle As String
AuditMonth = Range("F5").Value 'MONTH
AuditYear = Range("H5").Value 'YEAR
AuditTitle = Range("A5").Value 'TITLE
IfNewFolder 'creates a yearly subfolder
ActiveWorkbook.SaveAs Filename:= _
MYPATH & AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
MsgBox ("Audit Saved.")
'ActiveWindow.Close
End Sub
You can add the below sub and call it after IfNewFolder and remove all the code after it.
Private Sub Carla(AuditMonth, AuditYear, AuditTitle)
Dim CurWb As Workbook 'This is whatever workbook you are working with
Dim SaveAsWb As Workbook 'This is spare for the workbook in case that has the same name
Dim SaveFileName As String
Set CurWb = ActiveWorkbook
SaveFileName = AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm"
If Len(Dir(MYPATH & SaveFileName)) = 0 Then
CurWb.SaveAs FileName:=MYPATH & SaveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else
Set SaveAsWb = Workbooks.Open(MYPATH & SaveFileName)
CurWb.Worksheets("Sheet1").Copy After:=SaveAsWb.Worksheets(Sheets.Count)
SaveAsWb.Save
SaveAsWb.Close
End If
MsgBox ("Audit Saved.")
End Sub
I cleared your code a little bit - see below. I assumed that the values of AuditMonth, AuditYear and AuditTitle are placed in the "current" workbook.
Sub SaveCustomizedCourse()
'copy and paste selected data in a new workbook
Dim lngLastRow As Long
Dim wksThis As Excel.Worksheet
Dim wkbNew As Excel.Workbook
'save selected data in a new workbook
Dim AuditMonth As String
Dim AuditYear As String
Dim AuditTitle As String
Set wksThis = ActiveSheet
Set wkbNew = Workbooks.Add
With wksThis
lngLastRow = .Range("B8").End(xlDown).Row
AuditMonth = .Range("F5").Value 'MONTH
AuditYear = .Range("H5").Value 'YEAR
AuditTitle = .Range("A5").Value 'TITLE
.Range("B8:B" & lngLastRow).Copy
End With
With wkbNew.Sheets(1).Range("A1")
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteColumnWidths
End With
IfNewFolder 'creates a yearly subfolder
With wkbNew
.SaveAs Filename:= _
MYPATH & AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
.Close
End With
MsgBox ("Audit Saved.")
End Sub
I found that this variation of Peicong Chen's post helped a lot.
It works exactly like i want it to, thanks.
Public Sub IfSheetExists(AuditMonth, AuditYear, AuditTitle)
AuditMonth = Range("F5").Value 'MONTH
AuditYear = Range("H5").Value 'YEAR
AuditTitle = Range("A5").Value 'TITLE
Dim CurWb As Workbook 'This is whatever workbook you are working with
Dim SaveAsWb As Workbook 'This is spare for the workbook in case that has the same name
Dim SaveFileName As String
Set CurWb = ActiveWorkbook
SaveFileName = AuditYear & "\" & AuditTitle & "_" & AuditMonth & ".xlsm"
Application.DisplayAlerts = False
If Len(Dir(MYPATH & SaveFileName)) = 0 Then
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
CurWb.SaveAs Filename:=MYPATH & SaveFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
CurWb.Close
Else
Set SaveAsWb = Workbooks.Open(MYPATH & SaveFileName)
CurWb.Worksheets("Sheet1").Copy After:=SaveAsWb.Worksheets(Sheets.Count)
SaveAsWb.save
SaveAsWb.Close
CurWb.Close
End If
Application.DisplayAlerts = True
MsgBox ("Audit Saved.")
Range("A1").Select
End Sub

Excel VBA or Script to run the same macro (refreshes data connection from 1 file & repeats on other files in the same directory)

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

Saving specific named worksheets in workbook based on criteria using VBA

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

Resources