Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim wkbk As Workbook
Dim NewFile As Variant
NewFile = Application.GetOpenFilename(FileFilter:="Microsoft Excel Files
(*.xlsx; *.xls), (*.xlsx; *.xls), All Files, *.*", FilterIndex:=1)
If NewFile <> False Then
Set wkbk = Workbooks.Open(NewFile)
End If
Worksheets("Sunday").Unprotect "bunny"
Dim Sh As Worksheet
For Each Sh In ThisWorkbook.Worksheets
If Sh.Visible = True Then
Sh.Activate
Sh.Cells.Copy
Sh.Range("A1").PasteSpecial Paste:=xlValues
Sh.Range("A1").Select
End If
Next Sh
Application.CutCopyMode = False
Worksheets("Sunday").Protect "bunny", True, True
Application.ScreenUpdating = True
End Sub
Hello, pretty knew to VBA, can do tiny thing in it. I'm trying to make something which allows you to select an excel file to open, opens it, un-protects the sheet "Sunday", pastes over the data, re-protects, then saves and closes the document.
The main bit of code works on my current sheet if I don't include the portion to open a file, but when I am trying to use it on the workbook I have just opened, I am getting a 'Subscript out of range' error message. I am not too sure if I am the newly opened file is 'active', but when I tried insert a line of vba to make the new document active, it made no difference. Any advice would be appreciated.
Related
I would like to browse to the specific excel file and copy sheet1 of the file which is opening into the new sheet in my xlsm file. I have written the code like below:
Option Explicit
Sub test_copy_sheet()
Dim path As String
Dim filetoopen As Variant
Dim openwb As Workbook
filetoopen = Application.GetOpenFilename()
If filetoopen <> False Then
Set openwb = Application.Workbooks.Open(filetoopen)
openwb.Sheets(1).Copy
ThisWorkbook.Sheets.Add.Name = "mysheet"
ThisWorkbook.Sheets("mysheet").PasteSpecial xlPasteValues
openwb.Close False
End If
End Sub
When i ran the code, it get the issue as photo
I just want to copy sheet1 of the file opening to sheet name "mysheet". Could you please assist on this ?
As mentioned in the comments, please insert Option Explicit at the top of the module to ensure you declare all variables properly (and also pick up typo like thisworkbook and OpenBook)
Try this code below, it will open the file, copy the first sheet to ThisWorkbook and rename to mysheet:
Sub test_copy_sheet()
Dim filetoopen As Variant
Dim openwb As Workbook
filetoopen = Application.GetOpenFilename()
If filetoopen <> False Then
Set openwb = Application.Workbooks.Open(filetoopen, ReadOnly:=True)
openwb.Sheets(1).Copy ThisWorkbook.Sheets(1)
ThisWorkbook.Sheets(1).Name = "mysheet"
openwb.Close
End If
End Sub
Note: You will need to add additional check to be sure that ThisWorkbook does not have a sheet named mysheet. (i.e. no duplicate names)
So I have a worksheet that generates a chart type of thing using information on 2 other worksheets. On It I have an extract button which should copy the entire workbook into a new workbook whilst making the sheets where the data is pulled from invisible to the user. My issue is, the chart worksheet has other features which require macros to be run, for example buttons that hide some of it etc. The issue is I cannot find whether its actually possible to copy through macros from a workbook into the new copied workbook? Anyone have an answer to this and if so, how would you do this? Here is the code I currently have which copies the workbook into a new workbook:
Sub EWbtn()
Dim OriginalWB As Workbook, NewCRCWB As Workbook
Set OriginalWB = ThisWorkbook
Set NewCRCWB = Workbooks.Add
OriginalWB.Sheets("Generator").Copy Before:=NewCRCWB.Sheets("Sheet1")
OriginalWB.Sheets("Module Part Number Tracker").Copy Before:=NewCRCWB.Sheets("Generator")
OriginalWB.Sheets("CRC").Copy Before:=NewCRCWB.Sheets("Module Part Number Tracker")
Application.DisplayAlerts = False
NewCRCWB.Worksheets("Generator").Visible = False
NewCRCWB.Worksheets("Module Part Number Tracker").Visible = False
NewCRCWB.Worksheets("Sheet1").Delete
Application.DisplayAlerts = True
End Sub
I'd take a copy of the original file and delete/hide sheets from that.
All code is copied over as part of the save.
Sub Test()
Dim wrkBk As Workbook
Dim sCopyFileName As String
Dim wrkSht As Worksheet
sCopyFileName = "C:\MyFolderPaths\Book2.xlsm"
'Create copy of original file and open it.
ThisWorkbook.SaveCopyAs (sCopyFileName)
Set wrkBk = Workbooks.Open(sCopyFileName)
'wrkbk.Worksheets does not include Chart sheets.
'wrkbk.Sheets would take into account all the types of sheet available.
For Each wrkSht In wrkBk.Worksheets
Select Case wrkSht.Name
Case "Generator", "Module Part Number Tracker"
wrkSht.Visible = xlSheetVeryHidden
Case "CRC"
'Do nothing, this sheet is left visible.
Case Else
Application.DisplayAlerts = False
wrkSht.Delete
Application.DisplayAlerts = True
End Select
Next wrkSht
wrkBk.Close SaveChanges:=True
End Sub
I managed to find an answer to my question.. This code works fine however you need to add "Microsoft Visual Basic for Applications Extensibility 5.x" as a reference via Tools -> References. Here is the code:
Dim src As CodeModule, dest As CodeModule
Set src = ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
Set dest = Workbooks("Book3").VBProject.VBComponents("ThisWorkbook") _
.CodeModule
dest.DeleteLines 1, dest.CountOfLines
dest.AddFromString src.Lines(1, src.CountOfLines)
Credit: Copy VBA code from a Sheet in one workbook to another?
I need help saving specific tabs from excel workbooks as 1) csv files, and 2) files named after the file from which they originate.
So far I have this which works in taking out the right tab from a single workbook and saving it as a .csv file.
Sub Sheet_SaveAs()
Dim wb As Workbook
Sheets("SheetName").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs ThisWorkbook.Path & "\SheetName.csv"
'.Close False
End With
End Sub
How do I rename "SheetName" so that the file saves as, for example, Workbook1SheetName, Workbook2SheetName etc.?
I want to loop this function through a folder of many, many excel files, so unique names are necessary for the new .csv files.
I found this online which shows how to use a VBA loop, http://www.ozgrid.com/VBA/loop-through.htm. In theory it should work with my code above as long as each .csv file can have a unique name. Correct me if I am wrong.
Thanks for the help.
As you've discovered, when you copy a worksheet with no destination you end up with a new workbook populated by the copy of worksheet. The new workbook becomes the ActiveWorkbook property in the VBA environment. To save the workbook as a CSV file you need to retrieve the Worksheet .Name property of the sole worksheet in that new workbook.
Sub All_Sheet_SaveAs_CSV()
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
fp = .Path
'cycle through each of the worksheets
For w = 1 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=xlCSV
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Note that turning .DisplayAlerts will turn off the warnings that you would normally receive. While this is helpful with the CSV file format, it also will not warn you if you attempt to overwrite a file.
The Workbook.SaveAs method with a file format parameter of xlCSV will supply the correct file extension. There is no need to include it as part of the filename.
If a limited number of specific worksheets are intended to receive the export-to-CSV procedure, then an array of worksheet names could be cycled through rather than the worksheet index position.
Sub Specific_Sheets_SaveAs_CSV()
Dim v As Long, vWSs As Variant
Dim fp As String, fn As String
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
vWSs = Array("Sheet1", "Sheet3", "Sheet5")
'start with a reference to ThisWorkbook
With ThisWorkbook
fp = .Path
'cycle through each of the worksheets
For v = LBound(vWSs) To UBound(vWSs)
With Worksheets(vWSs(v))
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=xlCSV
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next v
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
In Excel, I altered some code to automatically copy text of a pre-selected range into a .txt file when the Command Button is clicked. For some reason, whenever this code attempts to copy from cells that have an =IF(AND( __, __ ), __, __) statement in it, it will not take the text, however it works perfectly fine for text that is simply entered into the cell with no form of equation. Also, the first few cells in the column are plain text without any equations, so having the equation in the code itself will not be desirable. What can I do to my code so it will not alter the information copied from Excel cells containing an equation referencing other cells? Code is exactly as seen below. Also, I am working in Excel 2007. Thank you!
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
On Error Resume Next
Set WorkRng = ActiveSheet.Range("A1:B25").Copy
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = Application.Workbooks.Add
wb.Worksheets(1).Paste
saveFile = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt")
wb.SaveAs Filename:=saveFile, FileFormat:=xlText, CreateBackup:=False
wb.Close
End Sub
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim saveFile As String
Dim WorkRng As Range
Set WorkRng = ActiveSheet.Range("A1:B25") '<<no .Copy
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = Application.Workbooks.Add
'WorkRng.Copy wb.Worksheets(1).Range("A1")
'copy values only
WorkRng.Copy
wb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
saveFile = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt), *.txt")
wb.SaveAs Filename:=saveFile, FileFormat:=xlText, CreateBackup:=False
wb.Close
End Sub
So prior to asking this I searched and found something that was similar to what I was looking to do here.
Basically I have workbook AlphaMaster. This workbook is a template that I want to use to create new workbooks from weekly.
In this workbook there are sheets named: Monday-Saturday and additional sheets with a corresponding date for Mon, Tues, ect.
I have created a Form that loads on open of the workbook. What I want is when I click form run it will:
Run Code saving template as new workbook
Rename workbook based of input from userform1
Rename the workbooks with proper weekday
Workbook is named for a week end date dates of 6 sheets would renamed after this(example week ending 5th of Jan.) is put into user form as:
WeekEnd: Jan-5-2014
Dates
Mon:Dec.30
Tues:Dec.31
Weds:Jan.1
Thurs:Jan.2
Fri:Jan.3
Sat:Jan.4
Than click command. so far this is what I have:
Private Sub CommandButton1_Click()
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
On Error GoTo dummkopf
Application.DisplayAlerts = False
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add
On Error Resume Next
For Each ws In wbTemp.Worksheets
ws.Delete
Next
On Error GoTo 0
For Each ws In thisWb.Sheets
ws.Copy After:=wbTemp.Sheets(1)
Next
wbTemp.Sheets(1).Delete
wbTemp.SaveAs "blahblahblah\New.xlsx"
new.xlsx i want to be filled in from form
Vorfahren:
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Vorfahren
End Sub
Complications:
Currently while this does work I cant change the name of the document its named what I name it in the .saveAs area. I'm thinking I need to create an alternate function to handle this. Second, when it finishes my sheets are displayed in the reverse order of the template.
Some guidance/suggestions on where to go from here would be greatly appreciated!
A few issues here:
You cannot delete all Worksheets in a Workbook.
You should copy the sheet to the end to retain order (if the worksheets in source workbook is sorted):
For Each ws In thisWb.Sheets
ws.Copy After:=wbTemp.Sheets(wbTemp.Sheets.Count)
wbTemp.Sheets(wbTemp.Sheets.Count).Name = "NewSheetName" ' <-- Rename the copied sheet here
Next
If your source Worksheets does not have names "Sheet#" then delete the default sheets afterwards.
Application.DisplayAlerts = False
For Each ws In wbTemp.Sheets
If Instr(1, ws.Name, "Sheet", vbTextCompare) > 0 Then ws.Delete
Next
Application.DisplayAlerts = True
For SaveAs, refer to Workbook.SaveAs Method (Excel).
I use this in my application and works good
Set bFso = CreateObject("Scripting.FileSystemObject")
bFso.CopyFile ThisWorkbook.FullName, destinationFile, True
Once it's copied you can then open it in new Excel Object and do what ever you want with it.