VBA code for saving xls.

[MagnusOlsen]

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]

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]

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