Copy Data from One sheet to another Workbook with same formating

[Darshan Shah]

Hello everyone..

I am stuck in code.. Here is the explanation with example.. Hope it is not confusing

I have made one model for order booking. I run it for each order to get optimum solutions. Now for the next step i want your help..

As example, I run this model for say "X" customer. I wanted to save that output in different workbook (Say Master File). Now i wanted the msg box which will rename that sheet name in "Master File". (by default the sheet name will be "Sheet1" but i want to make it as user input name) (For example i will rename that sheet as "X-order")

Now, for case 2, say for "Y" customer i ran the same model and output should be save in "Master File" in new sheet. Where i will rename with that msg box as "Y-Order".

So, finally in Master sheet there will be 2 sheets. 1st is "X-order" & the second is "Y-order". And so on..

Data should be save in Master file with the same format of "Model" i.e width of column & height of Raw. It consist "Image" too. That should also be copied too. and it should be values only. Not formula.

I have tried this below code, but output is new workbook.. I don't want that.. Please Help!

Sub Exportluck()

Dim strFileName As String

strFileName = InputBox("Type a name for the new workbook", "File Name")
If Trim(strFileName) = vbNullString Then Exit Sub

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Range("A4:O47").Copy
With ActiveWorkbook.ActiveSheet
.UsedRange.Value = .UsedRange.Value
End With
Sheets.Add.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveSheet.Move
ActiveWorkbook.SaveAs "C:\Users\Desktop\" & strFileName & ".xlsx"
ActiveWorkbook.Close False

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[Ralph Gregory]

Have you tried copy and save as a new workbook?
ActiveWorkbook.SaveCopyAs "C:\Users\Desktop\" & strFileName & ".xlsx"
no need to copy individual sheets and cells then open it and let the user fill it in as they need

 

[jolivanes]

If you want to save the Active Sheet as a workbook on your desktop.

Sub Copy_Save()
Dim strFileName As String
strFileName = InputBox("Type a name for the new workbook", "File Name")
ActiveSheet.Copy
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
        ActiveWorkbook.SaveAs CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & strFileName & ".xlsx", 51
    ActiveWorkbook.Close
End Sub

Have you considered saving the sheet as a PDF file since you don't want formulas?

 

[jolivanes]

If you want to save a sheet into an workbook that is in a folder on the desktop, this should do that for you.
Change references like sheet names, folder names etc as required.
Do not open the workbook yourself. Code will take care of that.

Sub Copy_Sheet_Into_Closed_Workbook()
Dim wb1 As Workbook, wb2 As Workbook
Dim shName As String
shName = InputBox("Type a name for the new sheet", "Sheet Name")
Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
        Set wb2 = Workbooks.Open(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Customer Bookings\Customers.xlsx")
        wb1.Sheets(1).Copy After:=wb2.Sheets(wb2.Sheets.Count)
        ActiveSheet.Name = shName
    wb2.Close True
Application.ScreenUpdating = True
End Sub

 

[Darshan Shah]

If you want to save a sheet into an workbook that is in a folder on the desktop, this should do that for you.
Change references like sheet names, folder names etc as required.
Do not open the workbook yourself. Code will take care of that.

Sub Copy_Sheet_Into_Closed_Workbook()
Dim wb1 As Workbook, wb2 As Workbook
Dim shName As String
shName = InputBox("Type a name for the new sheet", "Sheet Name")
Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
        Set wb2 = Workbooks.Open(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Customer Bookings\Customers.xlsx")
        wb1.Sheets(1).Copy After:=wb2.Sheets(wb2.Sheets.Count)
        ActiveSheet.Name = shName
    wb2.Close True
Application.ScreenUpdating = True
End Sub

Thank you Jolivanes.

This code is working for me. But macro is copying whole sheet in a new sheet. So it is also copying "Macro Button" which i have put in the top of the sheet.
Is it possible to copy a range with same formatting in values only mode with the image?

 

[jolivanes]

Can we just delete the button?
Are there any other shapes on that sheet?
Is the button's name "Button " and a number?

Please don't quote if not really needed.
Refer to a post number is a lot cleaner at the end.

 

[jolivanes]

Try this.

Sub Copy_Sheet_Into_Closed_Workbook()
Dim wb1 As Workbook, wb2 As Workbook
Dim shName As String
shName = InputBox("Type a name for the new sheet", "Sheet Name")
Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
        Set wb2 = Workbooks.Open(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Customer Bookings\Customers.xlsx")
        wb1.Sheets(1).Copy After:=wb2.Sheets(wb2.Sheets.Count)
        With ActiveSheet
            .Buttons.Delete
            .Name = shName
            .UsedRange.Value = .UsedRange.Value
        End With
        wb2.Close True
Application.ScreenUpdating = True
End Sub

 

[Darshan Shah]

Regarding post#6, button will be require for ease of operation. Because this model will be use by non skill labor.

It would be better if we can add range like Range("A4:O47").Copy.

But in this case, all data is being copied but not the image. Also same formatting is not being copied.

Regarding post#7, this code is not working.

 

[Darshan Shah]

If we can not select the range, the code given by you is working perfectly. All we need to do change in paste type. It should not contain formulas.

 

[jolivanes]

Re: "Regarding post#7, this code is not working."
What is not working?

Re: "It should not contain formulas. "

.UsedRange.Value = .UsedRange.Value

should take care of that.

If you insist on copy and paste, try this

Sub Add_Sheet_Copy_Paste_Into()
Dim wb1 As Workbook, wb2 As Workbook
Dim shName As String, sh2 As Worksheet
shName = InputBox("Type a name for the new sheet", "Sheet Name")
Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
        Set wb2 = Workbooks.Open(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Customer Bookings\Customers.xlsx")
            On Error Resume Next
                Set sh2 = wb2.Worksheets(shName)
        If Not sh2 Is Nothing Then
            MsgBox "This Workbook has a sheet with that name already. Select another name."
                wb2.Close False
            On Error GoTo 0
        Exit Sub
        End If
        wb2.Worksheets.Add(After:=wb2.Worksheets(Worksheets.Count)).Name = shName
        wb1.Sheets("Sheet1").Range("A4:O47").Copy
        With wb2.Sheets(shName).Cells(4, 1)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteFormats
        End With
        wb2.Close True
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub