I know i should probably be doing this in access or VB but I dont know how to use either. At the moment I have a submit button at the end of my form that saves and closes the workbook as whatever is inputted to a certain cell.
I am looking for a way to be able to do the same thing but break the worksheet out of the workbook. So it saves just the worksheet as its own excel file and with the name inputted into a certain cell. Below is the macro I am currently using.
Sub Saveworkbook()
Application.DisplayAlerts = False
Dim dName$, vName$
dName = Range("B8")
vName = ActiveWorkbook.FullName
ActiveWorkbook.SaveAs "W:\Test\" & dName
ActiveWorkbook.SaveAs vName
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
It would also be cool if it could add the date and computers user in to save name but not essential.
Thanks in advance
Sam
Something like this -
Sub SaveSheet()
Dim wbkDashboard As Workbook
Dim wsTarget As Worksheet
Set wsTarget = Thisworkbook.worksheets("Sheet1")
Dim strFileName As String
strFileName = wsTarget.Range("B8").Value _
& Format(Now, "ddmmyyyy") & "-" & Environ("username") & ".xlsx"
Set wbkDashboard = Workbooks.Add
wsTarget .Copy Before:=wbkDashboard.Sheets(1)
For intSheetCount = 2 To wbkDashboard.Sheets.Count
wbkDashboard.Sheets(2).Delete
Next
wbkDashboard.SaveAs "W:\Test\" & wsTarget.Range("B8").Value _
& Format(Now, "ddmmyyyy") & "-" & Environ("username") & ".xlsx"
wbkDashboard.Close
wsTarget.Range("B8").Value= strFileName
Set wsTarget = Nothing
Set wbkDashboard = Nothing
End Sub
This code will save any changes you have created in the current version, then it will save just the Active Sheet as a new workbook with the username and date (Credit to #Will on the Environment Variables).
Sub Saveworkbook()
Application.DisplayAlerts = False
Dim Sheet1 As Worksheet
Dim dName$, vName$, sName$
dName = Range("B8")
vName = ActiveWorkbook.FullName
sName = ActiveWorkbook.ActiveSheet.Name
For Each Sheet1 In ActiveWorkbook.Sheets
If Not Sheet1.Name = sName Then
Sheet1.Delete
End If
Next Sheet1
ActiveWorkbook.SaveAs "W:\Test\" & dName & "_" & Environ("username") & "_" & Format(Now, "ddmmyy") & "xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Related
Me again , I'm trying to code for spliting sheets in the xlsm file into the seperate sheet then save them in the same place with the xlsm file. the code as below:
Sub splitsheet()
Dim path As String
Dim cities
ReDim cities(1 To ThisWorkbook.Worksheets.Count)
Dim i As Long
Dim sh As Worksheet
path = ActiveWorkbook.path
For i = 1 To Worksheets.Count
cities(i) = Sheets(i).Name
ActiveWorkbook.SaveAs _
Filename:=path & "\" & Sheets(i).Name & ".xlsx"
'ActiveWorkbook.Close False
Next i
End Sub
The error in my photo below. Why it can not save as in "xlsx" extension , above code is work fine with "xlsm" extension
Filename:=path & "\" & Sheets(i).Name & ".xlsm" 'it can work fine with xlsm extension
My question is how can save as in "xlsx" extension in this case. All assist/explaination will be appriciated.
Please try this code.
Sub EachSheetToEachOwnWorkbook()
' 286
Dim Path As String
Dim Ws As Worksheet
Application.ScreenUpdating = False
Path = ThisWorkbook.Path & "\"
For Each Ws In ThisWorkbook.Worksheets
Ws.Copy
With ActiveWorkbook
.SaveAs Filename:=Path & Ws.Name & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
.Close
End With
Next Ws
Application.ScreenUpdating = True
End Sub
I have multiple Timesheet workbooks set up which has Employee Name and multiple columns for different hour types (eg. Base Hours, Holiday Pay, Sick Pay). See image .
I need code to be able to copy for each employee the type of hours (heading) and the value into 4 columns.
eg.
Employee 1 Base Hours 37.50
Employee 1 Sick Hours 15.00
Employee 1 Group Leader 20.00
Employee 2 Base Hours 50.00
Employee 2 Holiday Pay 60.00
I have some code which copies the data to a template currently but stuck on how to copy it as above.
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Sheets("Timesheet").Range("A9:N" & Range("A" &
Rows.Count).End(xlUp).Row).Copy
Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport").Range("A"
& Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
NewBook.Close savechanges:=True
End Sub
Example Timesheet File
Example Upload Template
Using the function at the link I posted, something like this (untested):
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Dim rngData, p, shtDest As Worksheet
Set shtDest = Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
'<edited> range containing your data
With wb.Sheets("Timesheet")
Set rngData = .Range("A9:N" & _
.Range("A" & .Rows.Count).End(xlUp).Row)
End with
'</edited>
p = UnPivotData(rngData, 2, True, False) '<< unpivot
'put unpivoted data to sheet
With shtDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(UBound(p, 1), UBound(p, 2)).Value = p
End With
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
NewBook.Close savechanges:=True
End Sub
I am trying to save a particular worksheet from my working workbook to another workbook, and trying to save it in the path of my current workbook. The saving option is in such a way that it should get saved with the dd.mm.yyyy.
I tried the following code and I am getting application defined error in the line
> newWB.SaveAs filename:=Path2 & Format(Now(), "yyyymmdd") &
> myWorksheets(i), FileFormat:=xlsx
Could you please help me figure out where I am wrong?
Sub save()
Dim myWorksheets() As String 'Array to hold worksheet names to copy
Dim newWB As Workbook
Dim CurrWB As Workbook
Dim i As Integer
Dim path1, Path2
path1 = ThisWorkbook.Path
Path2 = path1 & "\TT"
Set CurrWB = ThisWorkbook
myWorksheets = Split("Report", ",")
For i = LBound(myWorksheets) To UBound(myWorksheets) 'Go through entire array
Set newWB = Workbooks.Add 'Create new workbook
CurrWB.Sheets(Trim(myWorksheets(i))).Copy
newWB.SaveAs filename:=Path2 & Format(Now(), "yyyymmdd") & myWorksheets(i), FileFormat:=xlsx
newWB.Close saveChanges:=False
Next i
CurrWB.Save 'save original workbook.
End Sub
#Jenny - This code will accomplish what you ask in your question, it will save the ActiveSheet as a new file; and can be used as a function the can be called within your code. You can change the "Rpt" to identify the title of the new workbook. When I'm writing vba code, I always try to follow what my mother use to say to me, "Keep it simple".
Application.DisplayAlerts = False
Dim wbPath As String
wbPath = ThisWorkbook.Path
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=wbPath & "\" & "Rpt" & " " & Format(Date, "yyyymmdd") & ".xlsx", _
FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
I have a master Excel sheet designed to spit out payroll details. The numbers on the sheet are driven by a data validation dropdown in A2, which fills in B2:G2 with identifying information (Last, First, Region, PayPeriod, Year) pulled from a data tab.
What I'd like to do is have a macro save a copy of the sheet for each choice in the dropdown into a specific folder in a hierarchy based on the info in B2:G2.
For instance,
ID Last First Region PP Year
10001 Smith Scott DC PP1 2016
I'd like that to save a sheet named "2016_PP1_DC_Smith_Scott.xlsx" in the folder C:\2016\PP1\DC.
And then change to
ID Last First Region PP Year
10002 Jones Karen NY PP3 2015
And save the sheet "2015_PP3_NY_Jones_Karen.xlsx" in the folder C:\2015\PP3\NY.
I have a macro that's part of the way there. It goes through each drop down and saves the file with the correct filename (Though it's renaming the initial file) (edit) I need help adding the functionality to save the sheets in a hierarchy of folders and not overwrite the original document with the most recent saved sheet name.
Totally fine with continuing to use this macro with edits or start from scratch.
Sub PrintValidationChoices()
Dim wbSource As Workbook
Dim r As Long, i As Long
Dim relativePath As String
Dim year As String
Dim quarter As String
Dim pp As String
Dim region As String
Dim doctor As String
Set wbSource = ActiveWorkbook
r = Range("ID").Cells.Count
For i = 1 To r
Range("A2") = Range("ID").Cells(i)
year = ActiveSheet.Range("G2")
pp = ActiveSheet.Range("F2")
region = ActiveSheet.Range("E2")
hospital = ActiveSheet.Range("D2")
doctor = ActiveSheet.Range("B2") & "_" & ActiveSheet.Range("C2")
'visually validating what will be used - not needed
Range("H3") = year
Range("H4") = pp
Range("H5") = region
Range("H6") = hospital
Range("H7") = doctor
sname = year & "_" & pp & "_" & region & "_" & hospital & "_" & doctor & ".xls"
relativePath = wbSource.Path & "\" & sname 'use path of wbSource
Range("H8") = relativePath
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True
Application.Wait (Now + TimeValue("00:00:01")) 'pausing to see actions - not needed
Next i
Range("A2") = Range("ID").Cells("1") 'return to start of list
MsgBox "Done!"
End Sub
Thank you guys for the help! If you're feeling verbose, it would be great to have some details in your response so I can learn.
edited to reflect most probable validation worksheet name
maybe you're after something like what follows:
Option Explicit
Sub main()
Dim strng As String
Dim cell As Range
With Worksheets("Report") '<--| change "Report" to your actual worksheet name
For Each cell In Range(.Range("a2").Validation.Formula1).SpecialCells(XlCellType.xlCellTypeConstants)
.Range("a2") = cell.Value
SaveWorksheet .Range("B2:G2")
Next cell
End With
End Sub
Sub SaveWorksheet(rng As Range)
Dim sname As String, relativePath As String
Dim folder As String
folder = "C:\" & rng(1, 6) & "_" & rng(1, 5) & "_" & rng(1, 4)
MkDir folder
sname = rng(1, 6) & "_" & rng(1, 5) & "_" & rng(1, 4) & "_" & rng(1, 3) & "_" & rng(1, 2) & "_" & rng(1, 3) & ".xls"
relativePath = folder & "\" & sname
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
rng.Parent.Copy
With ActiveWorkbook
.SaveAs filename:=relativePath ', FileFormat:=xlExcel8
.Close
End With
Application.DisplayAlerts = True
Application.Wait (Now + TimeValue("00:00:01")) 'pausing to see actions - not needed
End Sub
Basically, I'd like to save some worksheets into separate new workbooks in the same system location as original notebook I am deriving from.
I recognize that the default path is to save something new is to the location of the current notebook, but perhaps since I am opening a new workbook the default reverts to the user's Document's folder, which is where they are saving right now.
I "learned" VBA over the last couple of days, so advice on other things you notice is cool too, but the saveas is what's bothering me.
Dim ws As Worksheet
Dim wb As Workbook
Dim dept_array As Variant
Dim dept As Variant
' Add or remove a department name spelled exactly as it is in the filter
dept_array = Array("HR", "IT", "Marketing", "Product Marketing", "Sales", "Channels", "Presales", "Direct", "Sales Ops", "R&D", "Support", "G&A")
Application.ScreenUpdating = False
For Each ws In Workbooks("Weekly Department Transaction Report.xlsm").Worksheets
For Each dept In dept_array
If Application.Proper(ws.Name) = Application.Proper(dept) _
Then
Set wb = Workbooks.Add
ThisWorkbook.Sheets(dept).Copy Before:=wb.Sheets(1)
wb.Saveas dept & "_" & Format(Now, "yyyymmdd") & ".xlsx"
Workbooks("Weekly Department Transaction Report.xlsm").Sheets("Codes").Copy After:=Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Sheets(dept)
Workbooks("Weekly Department Transaction Report.xlsm").Sheets("How").Copy Before:=Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Sheets(dept)
Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Save
End If
Next dept
Next ws
Application.ScreenUpdating = True
End Sub
Please let me know if I am not following the correct stackoverflow format.
Longtime user first time asker :)
Edit this line in your code:
wb.SaveAs FileName:= ThisWorkbook.Path & "\" & dept & "_" & Format(Now, "yyyymmdd") & ".xlsx"