PDA

View Full Version : VBA code for saving xls.



MagnusOlsen
05-24-2017, 04:36 AM
Hi,

I am new here (and also a rookie w.r.t VBA) so don't know if this is the right place for this question. However,
I need help to build a code that saves the whole excel file and a tab within the excel file in two different folders.

The whole model should be saved here; \\test\test1\Review 2017\Full Model

and the tab within the sheet (tab called PR2017) should be saved here \\test\test1\Review 2017\For Matlab

The name of both files should be AccountName &»_»& AccountNumber &»_»& DateNow

where
AccountName = sheets("Account Input").Range("b3")
AccountNumber = sheets("Account Input").Range("b4")
DateNow = sheets("Account Input").Range("b45")

In the end I want to click on a button that execute the code above and saved the two files.

Is there anybody out there that can help me? All help is appreciated,

Br, Magnus

mdmackillop
05-24-2017, 05:37 AM
This will save a copy of the original workbook and a copy of the specified sheet in the designated locations. It will not create the paths nor save the active workbook.

Option Explicit
Private Sub CommandButton1_Click()
Call DoSave
End Sub


Private Sub DoSave()
Dim Pth As String, FName As String
Dim sh As Worksheet
Pth = ActiveWorkbook.Path
With Sheets("Account Input")
FName = "Account Name_" & .[B3] & " " & .[B4] & " " & Format([B45], "yy_mm_dd") & ".xls"
End With
ActiveWorkbook.SaveCopyAs Pth & "\" & "test\test1\Review 2017\For Matlab\" & FName


Sheets("PR2017").Copy
ActiveWorkbook.SaveAs Pth & "\" & "test\test1\Review 2017\For Matlab\" & FName
ActiveWorkbook.Close False
End Sub

GTO
05-24-2017, 06:12 AM
Another try: I tested for the sheets of interest and the paths needed, but failed to test to see if the files have been previously created...



Option Explicit

Sub example()
' |
Const PATH As String = "\\test\test1\Review 2017\"


Dim WB As Workbook
Dim WKS As Worksheet
Dim shtAccountInput As Worksheet
Dim shtPR2017 As Worksheet
Dim strAccountName As String
Dim strAccountNumber As String
Dim strDateNow As String


'Assumes we are saving thisworkbook and a sheet from it...

'Attempt to set a reference to the sheets needed
On Error Resume Next
Set shtAccountInput = ThisWorkbook.Worksheets("Account Input")
Set shtPR2017 = ThisWorkbook.Worksheets("PR2017")
On Error GoTo 0

'If both sheets exist
If (Not shtAccountInput Is Nothing) And (Not shtPR2017 Is Nothing) Then
'If both paths exist
If CBool(Len(Dir(PATH & "Full Model\", vbDirectory))) And CBool(Len(Dir(PATH & "For Matlab\", vbDirectory))) Then
'If B45 is a valid date and we're a .xls format
If IsDate(shtAccountInput.Cells(45, "B").Value) And ThisWorkbook.FileFormat = xlExcel8 Then

strAccountName = shtAccountInput.Cells(3, "B").Value
strAccountNumber = shtAccountInput.Cells(4, "B").Value
strDateNow = Format(shtAccountInput.Cells(45, "B").Value, "yyyy-mm-dd")

'create a new one-sheet book
Set WB = Workbooks.Add(xlWBATWorksheet)

'Copy each sheet to the new workbook while leaving any standard module code behind
For Each WKS In ThisWorkbook.Worksheets
WKS.Copy After:=WB.Worksheets(WB.Worksheets.Count)
Next

'Kill the initial sheet
Application.DisplayAlerts = False
WB.Worksheets(1).Delete
Application.DisplayAlerts = True

WB.SaveAs PATH & "Full Model\" & strAccountName & Chr$(32) & strAccountNumber & Chr$(32) & strDateNow & ".xls", xlExcel8
WB.Close False

'SAA
Set WB = Workbooks.Add(xlWBATWorksheet)

shtPR2017.Copy After:=WB.Worksheets(1)
Application.DisplayAlerts = False
WB.Worksheets(1).Delete
Application.DisplayAlerts = True

WB.SaveAs PATH & "For Matlab\" & strAccountName & Chr$(32) & strAccountNumber & Chr$(32) & strDateNow & ".xls", xlExcel8
WB.Close False

End If
End If
End If

End Sub


Hope that helps,

Mark