VBA Copy sheet to new Excel File + automated manual data entry [Solved/Closed]
Sib -
Mar 23, 2015 at 04:58 AM - Latest reply: MaxStart346
Posts Tuesday March 3, 2015Registration dateContributorStatus
July 3, 2015
Last seen
- Mar 28, 2015 at 03:23 PM
I hope this is not a to extensive VBA script request and this is the place to ask.
I need to create a excel file in an automated way as following:
I have an excel file with around 25 sheets (can grow in the future).
Each sheet has a specific name to it, that will not change.
The number of columns on each sheet is the same (28), but the number of rows varies.
In short I need to create a new file with a perfect copy of one of the sheets of my choosing.
That's not all, data in column 2, 15 & 16 is unique but needs to be entered manually for each row, as from row 3, row 1 an 2 being headers/titles.
I wish also the naming of the file be customized as follow: "standardname_sheetname_variabledata_column2data_column15data.xls"
this file will have to be stored on a shared drive starting with http:// or // I'm not sure yet.
The source file is by the way also on a shared drive.
The way I see this happen:
In another excel file I have
- a column/cell with a drop down containing the list of my sheet names
- 3 columns with the data I need to enter manually for column 2,15 & 16
- the variable data for the file naming
- data for standard name for the file naming
I push the button and you VBA magic does the trick ;o).
I this request understandable? Am I asking to much?
I'm working with Office Professional Plus 2010.
please check this example and study it before asking, I will give it a bit more time when I get free, in the mean time you might check it out and try to adapt it to your needs, basically here two sheets are named copy me and copy me 2
Option Explicit
Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("Copy Me", "Copy Me2")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
Copy the above code.
Open any workbook.
Press Alt + F11 to open the Visual Basic Editor (VBE).
From the Menu, choose Insert-Module.
Paste the code into the right-hand code window.
Close the VBE (Alt + Q)
--
Damn it !!!, is it ever gonna be the way I want it to be?
I tested it and it worked fine.
This copy's a sheet you specified in the code to a new Excel file.
I could make this work. What I would do is create a button per sheet I need to copy. (I only need one sheet at a time).
This fur-fills only part of me needs, but it's a good start.
Option Explicit
Sub go()
Dim NewName As String
With Application
.ScreenUpdating = False
On Error GoTo ErrCatcher
On Error GoTo 0
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
ActiveSheet.Copy
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
