• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 418
  • Last Modified:

Create duplicate sheet - macro needed

I am using Excel 2010.

I need a macro that will, with a single (1) click...

1) Make a duplicate file from the active sheet.
2) Prompt for a new name for that file.
3) Ensure that the new file has only one tab and is stripped of any self-containing macros.

Is there any way to accomplish this?
0
rtod2
Asked:
rtod2
  • 8
  • 5
  • 2
1 Solution
 
Michael FowlerSolutions ConsultantCommented:
Here is a sub that will do what you need. You can create a button on your workbook and attach it to this macro so it can be run at anytime

Michael
Sub test()
   Dim current As Workbook, created As Workbook
   Dim sht As Worksheet
   Dim fn As String
   
   
   Set current = ActiveWorkbook
   Set sht = current.ActiveSheet
      
   sht.Copy
     
   fn = Application.GetSaveAsFilename
   If fn = False Then
      Application.DisplayAlerts = False
      ActiveWorkbook.Close
      Application.DisplayAlerts = True
      Exit Sub
   End If
   
   ActiveSheet.SaveAs fileName:=fn & ".xlsx"
   
End Sub

Open in new window

Book1.xlsm
0
 
rtod2Author Commented:
Awesome!  Here is a video of my implementation.

http://screencast.com/t/s5WL3l2LKo

It created an error for me.  I also noticed prior to making the video, that I had to tell it to go to the desktop.  I'd prefer that it find the active desktop by default if possible.

Thanks for your help with this Michael!!
0
 
Michael FowlerSolutions ConsultantCommented:
Sorry about that small error now corrected and it will automatically open the file dialog box in the current users desktop. This should work fine on any version of windows

Michael


Sub test()

   Dim sht As Worksheet
   Dim fn As String
   Dim wss As Object
   
   Set sht = current.ActiveSheet
      
   sht.Copy
   
   Set wss = CreateObject("WScript.Shell")
   ChDir wss.specialfolders("Desktop")
   Set wss = Nothing
   
   fn = Application.GetSaveAsFilename
   If fn = "False" Then
      Application.DisplayAlerts = False
      ActiveWorkbook.Close
      Application.DisplayAlerts = True
      Exit Sub
   End If
   
   ActiveSheet.SaveAs fileName:=fn & ".xlsx"
   
End Sub

Open in new window

Book1.xlsm
0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

 
Saqib Husain, SyedEngineerCommented:
Michael,

If the sheet has some macros they would be copied over as well. Maybe you need to do something like this.

Also on 2003  the returned file name contained a period so I omitted the period from the saveas statement.

Saqib
Sub ws2newfile()
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
wb.Worksheets.Add
ws.Cells.Copy ActiveSheet.Cells
ActiveSheet.Move
fn = Application.GetSaveAsFilename
If fn <> False Then
ActiveWorkbook.SaveAs fn & "xls"
Else
MsgBox "file not saved"
End If
End Sub

Open in new window

0
 
rtod2Author Commented:
Thanks.  I got the error even earlier this time.  Here is the video http://screencast.com/t/qW92TQyb

I am very grateful for your help.
0
 
rtod2Author Commented:
Thanks to you both!!

ssaqibh,  
I have this video on what I got with that one http://screencast.com/t/0797UabYXbSh .

I also noticed that it hangs onto the local macros as well.  
0
 
Saqib Husain, SyedEngineerCommented:
Ted, did you try mine?
0
 
rtod2Author Commented:
Yes, I even tried to pronunciate your name.  Did you see my video response?
0
 
Saqib Husain, SyedEngineerCommented:
Yes I had to get a pair of earphones to be able to listen to you.

You can try to pronounce it like sarkib. I would pronounce the q from the throat rather than the back of the tongue. Frequently people in my country, Pakistan, tend to deliver it from the tongue instead of the throat.

About the filename extension, I have been doing this on 2003 so used the xls extension. Try changing this to xlsx instead. I hope this will take care of the problem. I shall come back on the desktop issue.

Saqib

0
 
Saqib Husain, SyedEngineerCommented:
See if this works
Sub ws2newfile()
dtpath = CreateObject("wscript.shell").SpecialFolders("Desktop")
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
wb.Worksheets.Add
ws.Cells.Copy ActiveSheet.Cells
ActiveSheet.Move
fn = Application.GetSaveAsFilename(dtpath)
If fn <> False Then
ActiveWorkbook.SaveAs fn & "xlsx"
Else
MsgBox "file not saved"
End If
End Sub

Open in new window

0
 
rtod2Author Commented:
Thanks for continuing with this.

I used Excel 2010 and Windows 7 to run the test.

It did work without error and stripped the macros from the file.  It did not take auto-select the current user's desktop as the location.  

Getting closer clearly.
0
 
Saqib Husain, SyedEngineerCommented:
>>> It did not take auto-select the current user's desktop as the location.  

Did it take a different user's desktop or was it not the desktop?

Can you step through the lines and see what value does the variable dtpath take?
0
 
rtod2Author Commented:
Pretty darn sure that does it, Thank You!
0
 
rtod2Author Commented:
Here is a follow-up question from this.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

  • 8
  • 5
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now