I have following code, which Saves file automatically as per my desired output, I want to make 2 changes into it
ask for file name, currently it saves automatically with "Carrier Files"
copy sheets from 5th sheet to last sheet
Sub Splitbook()
Dim xWs As Worksheet
Dim xPath As String
xPath = Application.ActiveWorkbook.Path & "\Carrier Files"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ActiveWorkbook.Worksheets
xWs.UsedRange.Value = xWs.UsedRange.Value
Next xWs
Application.ActiveWorkbook.SaveAs Filename:=xPath & "" & AD & ".xlsx"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("NIFTY WEEK ALL").Select
MsgBox ("Done.")
End Sub
To ask for the filename you could use a simple InputBox like so:
xPath = Application.ActiveWorkbook.Path
AD = InputBox("Enter desired filename")
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & AD & ".xlsm"
To copy sheet 5:
Sheets(5).Copy After:=Sheets(Sheets.Count)
Use a Inputbox() for file name to enter. Try below sub
Sub Splitbook()
Dim xWs As Worksheet
Dim xPath As String
Dim myFile As String
xPath = Application.ActiveWorkbook.Path & "\Carrier Files\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ActiveWorkbook.Worksheets
myFile = InputBox("Enter a file name to save", "File Name", xWs.Name) 'Input file name
xWs.UsedRange.Value = xWs.UsedRange.Value
Next xWs
Application.ActiveWorkbook.SaveAs Filename:=xPath & myFile & ".xlsm"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("NIFTY WEEK ALL").Select
MsgBox ("Done.")
End Sub
Related
I am using the following code to create new sheets based on an bigger excell file.
I would like to rename the files like "nameofthesheet_Vouchering Hours August 2022_YTD" for each sheet, currently I am only getting "nameofthesheet". How can I change the code in order to have it like this?
Sub Separar_guias()
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 & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
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 would like to open a workbook using a wildcard or partial name match and save a copy with another name.
However, there is an error -
Always at the " Workbooks(myFolderPath & "" & MyFileName).SaveCopyAs Filename:="NEW NAME.xlsx" " line
Here is my code:
Sub GENERATE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'If workbook name like "Report Due" then open, if not already opened
Dim MyFileName As Variant
Dim myFolderPath As String
myFolderPath = Application.DefaultFilePath
MyFileName = Dir(myFolderPath & "\" & "Report Due*.xlsx")
If MyFileName <> "" Then
Workbooks.Open (myFolderPath & "\" & MyFileName)
End If
Workbooks(myFolderPath & "\" & MyFileName).SaveCopyAs Filename:="NEW NAME.xlsx"
Workbooks(myFolderPath & "\" & MyFileName).Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I'd be happy to see what's wrong! Many thanks!
Set a reference to the workbook when you open it, then you shouldn't need to use it's name to reference when saving the copy.
Option Explicit
Sub GENERATE()
Dim wb As Workbook
Dim MyFileName As Variant
Dim myFolderPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'If workbook name like "Report Due" then open, if not already opened
myFolderPath = Application.DefaultFilePath
MyFileName = Dir(myFolderPath & "\" & "Report Due*.xlsx")
If MyFileName <> "" Then
Set wb = Workbooks.Open(myFolderPath & "\" & MyFileName)
wb.SaveCopyAs Filename:="NEW NAME.xlsx"
wb.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This code works perfectly it saves an excel file to CSV-UTF8 and adds a timestamp in front of the file named "Test".
However, when I assign this code to a button, I'm always getting an error 400 for some reason.
So what I did is put the same code inside a module and debug it, and it didn't give me any errors it executed the code without any problems.
Can someone help me get this to work while using a button?
Sub SaveWorkSheetAsCSV()
Dim wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim name As String, myPath As String
comp = Environ("username")
myPath = "C:\" & comp & "\Testing\" 'use here the path you need
Set wsSource = ThisWorkbook.Worksheets(1)
name = Format(Now, "yyyymmdd-hh.mm") & " Testing"
Application.DisplayAlerts = False 'will overwrite existing files without asking
Set wbNew = ActiveWorkbook
wbNew.SaveAs myPath & "\" & name & ".csv", xlCSVUTF8 'new way
wbNew.Close
Application.DisplayAlerts = True
End Sub
Error 1004
Recieving the following error on this part:
wbNew.SaveAs myPath & "\" & name & ".csv", xlCSVUTF8 'new way
Export to CSV
'Semicolon users' might want to add , Local:=True to the SaveAs line to get the result separated by the semicolon.
ThisWorkbook.FollowHyperlink FolderPath will open the folder in Windows File Explorer.
The Code
Option Explicit
Sub SaveWorkSheetAsCSV()
Dim FolderPath As String
FolderPath = Environ("USERPROFILE") & "\Testing"
' or:
'FolderPath = "C:\Users\" & Environ("USERNAME") & "\Testing"
' Print the path to the Immediate window (CTRL+G).
'Debug.Print FolderPath
Dim FileName As String: FileName = Format(Now, "yyyymmdd-hh.mm ") & " Test"
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(2)
Application.ScreenUpdating = False
sws.Copy
Dim dwb As Workbook: Set dwb = ActiveWorkbook
Application.DisplayAlerts = False
dwb.SaveAs FolderPath & "\" & FileName & ".csv", xlCSVUTF8 ', Local:=True
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Application.ScreenUpdating = True
'ThisWorkbook.FollowHyperlink FolderPath
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