saving sheets from a new workbook excel-CodePudding

i have an issue with this code. I need to save the data from a workbook to a new workbook but the new workbook doesn't save, I do it manually. I need it to save automatically. Any idea what is going on?

this is my code so far

Private Sub CommandButton3_Click()


Dim wb As Workbook
Dim wb_New As Workbook

Set wb = ThisWorkbook
Dim wbstring As String
Dim input_file_name As String

input_file_name = InputBox("Enter file name", "Enter new workbook file name")

wbstring = "C:\PIME\\"

Workbooks.Add.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Set wb_New = ActiveWorkbook


wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value

End Sub

CodePudding user response：

You got it almost right - Set wb_New to the new workbook, populate the data then use SaveAs method.

Set wb_New = Workbooks.Add

wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value

wb_New.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56

CodePudding user response：

Copy a Range to a New One-Worksheet Workbook

The only mistake I could find was that you need to remove one of the two trailing backslashes from the path:
```
wbstring = "C:\PIME\"
```

An Improvement

Option Explicit

Private Sub CommandButton3_Click()
    
    ' Source
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("NUMB")
    
    ' Destination
    
    Dim dFolderPath As String: dFolderPath = "C:\PIME\"
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    
    Dim dExtension As String: dExtension = ".xls"
    If Left(dExtension, 1) <> "." Then dExtension = "." & dExtension
    
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then
        MsgBox "The path '" & dFolderPath & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    Dim dFileName As String
    dFileName = InputBox("Enter file name", "Enter new workbook file name")
    If Len(dFileName) = 0 Then
        MsgBox "Canceled or no entry."
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet) ' single...
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1) ' ... worksheet,...
    ' ... in another language it may not be 'Sheet1'.
    
    ' Copy by Assignement (the most efficient way to copy only values)
    
    dws.Range("A1:I2000").Value = sws.Range("A1:I2000").Value
    
    ' Save(As)
    
    Dim dFilePath As String: dFilePath = dFolderPath & dFileName & dExtension
    
    Dim ErrNum As Long
    Application.DisplayAlerts = False ' overwrite without confirmation
    On Error Resume Next
        dwb.SaveAs Filename:=dFilePath, FileFormat:=xlExcel8 ' or 56
        ErrNum = Err.Number
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    ' Close
    
    dwb.Close SaveChanges:=False
    
    ' Inform
    
    If ErrNum = 0 Then
        MsgBox "File saved.", vbInformation
    Else
        MsgBox "Could not save the file.", vbCritical
    End If
    
End Sub

CodePudding user response：

You may tweak your code as below...

Workbooks.Add.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Set wb_New = ActiveWorkbook


wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value

'Then either use wbNew.Save or wbNew.Close True as per your need
wbNew.Save 'To save the work and leave the new workbook open

'OR

wbNew.Close True    'To save the work and close the new workbook.