Copy Data from One sheet to another Workbook with same formating

Darshan Shah

New Member
Joined
Jul 4, 2020
Messages
11
Office Version
  1. 365
Platform
  1. Windows
Hello everyone..

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


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!


VBA Code:
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
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
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
 
Upvote 0
If you want to save the Active Sheet as a workbook on your desktop.
Code:
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?
 
Upvote 0
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.
Code:
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
 
Upvote 0
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.
Code:
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?
 
Upvote 0
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.
 
Upvote 0
Try this.
Code:
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
Re: "Regarding post#7, this code is not working."
What is not working?

Re: "It should not contain formulas. "
Code:
.UsedRange.Value = .UsedRange.Value
should take care of that.

If you insist on copy and paste, try this
Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top