I am trying to create a duplicate button on the excel ribbon which when clicked, will create a duplicate file of the active workbook but I want it to create a duplicate file having only first two sheets copied in the duplicate file and not the whole active workbook.
I tried the below code for getting the duplicate file :
Sub DupliquerFeuille(control As IRibbonControl)
Dim Sourcewb As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & ActiveWorkbook.Name
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & nom
' ActiveWorkbook.Sheets(Array(1, 2)).Copy
End Sub
But I am getting all sheets of active workbook copied in the duplicate file. Can anyone please help me in getting only the first sheets of active workbook copied in the duplicate file. I tried a lot but I am unable to get the result.
Try this:
Sub DupliquerFeuille(control As IRibbonControl)
Dim twb As Workbook
Dim Sourcewb As Workbook
Const shc As Long = 2 ' change this as you need, this will copy first 2 sheets
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Sourcewb.Sheets(1).Copy
Set twb = ActiveWorkbook
For i = 2 To shc
Sourcewb.Sheets(i).Copy ,twb.Sheets(twb.Sheets.Count)
Next
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & Sourcewb.Name
twb.SaveAs Sourcewb.Path & "\" & nom, Sourcewb.FileFormat
twb.Close False
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
How about just adding an extra few lines of code after you save the new workbook to delete out those pages you don't like?
Such as
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Replace "Sheet 1" with the name of the sheet (keep the quotation marks)
Below code lines find the path and name of current excel file, copy the first two sheets and save to a new (duplicated) workbook in the same location as the main workbook:
Set Sourcewb = ActiveWorkbook
' Create path and name for export
PathName = ThisWorkbook.Path & "_export"
' Copy the sheets so they don't get removed in the main file
Sheets(Array(1, 2)).Copy Before:=Sheets(1)
' Move the first two sheets to a new workbook
Sheets(Array(1, 2)).Move
' Save the active duplicated workbook
ActiveWorkbook.SaveAs Filename:=PathName, FileFormat:=Sourcewb.FileFormat
' Close the active duplicated workbook
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Related
I am trying to create a macro to copy certain cells from one workbook to another. I need to append the new data to data that has already been transferred. I am trying to modify this code to do so, but am not having success:
Sub Consolidate()
'Author: Jerry Beaucaire'
'Date: 9/15/2009 (2007 compatible) (updated 4/29/2011)
'Summary: Merge files in a specific folder into one master sheet (stacked)
' Moves imported files into another folder
' Edited/altered by Jay Chase 6/9/2017
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long
Dim wbData As Workbook, wsMaster As Worksheet
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("BM Condition") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(1).EntireRow.Clear
NR = 2
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'Path and filename (edit this section to suit)
fPath = "C:\Users\jchase.BRYCEWORLD\Desktop\Test\" 'remember final \ in this string"
fPathDone = fPath & "Imported\" 'remember final \ in this string
On Error Resume Next
MkDir fPathDone 'creates the completed folder if missing
On Error GoTo 0
fName = Dir(fPath & "*New BM Analysis 3.xls") 'listing of desired files, edit filter as desired
'Import a sheet from found files
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then 'don't reopen this file accidentally
Set wbData = Workbooks.Open(fPath & fName) 'Open file
'This is the section to customize, replace with your own action code as needed
LR = Range("A" & Rows.Count).End(xlUp).Row 'Find last row
Range("P14:S" & LR).EntireRow.Copy .Range("A" & NR)
wbData.Close False 'close file
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'Next row
Name fPath & fName As fPathDone & fName 'move file to IMPORTED folder
End If
fName = Dir 'ready next filename
Loop
End With
ErrorExit: 'Cleanup
ActiveSheet.Columns.AutoFit
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
I have little experience with VBA. Any help with how or why or why not I can do this is appreciated. I am still experimenting; if I have any breakthroughs I will update.
EDIT: so i have realized this code has to be called from the workbook i want to write to, but i need to call it from the workbook i am reading from. Is there a way to modify this script to do so?
I have a VBA macro which allows me to export in CSV (using the comma as separator) some sheets of my excel file, in this case, first 7 sheets. I have following problems:
The code allows to export first 1 - n sheets, but I would like to put the code to select sheets by name. In this case I could also export the sheet 1, called "MILANO" and the sheet 5, called "ROME".
I cannot find the way to save the CSV files automatically in the same folder of the source excel file. I used ActiveWorkbook.Path or ThisWorkbook.Path, but I guess I wrong something
I cannot export only rows of each sheet not-empty as in the CSV I see hundreds of rows with ,,,,,,,,,
Here the macro:
Sub CreateCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'-----------------------------
'DECLARE AND SET VARIABLES
Dim wb1 As Workbook, ws1 As Worksheet
Dim wbname As String, I As Integer
Set wb1 = ThisWorkbook
'-----------------------------
'CYCLE THROUGH SHEETS AND MATCH UPLOAD
For I = 1 To 7
wbname = Worksheets(I).Name
'-----------------------------
'COPY SHEET INTO NEW CSV FILE
Worksheets(I).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & wbname & "/.csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
wb1.Activate
Next I
'-----------------------------
'CLEANUP
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Thanks!
try this for your point 2
ActiveWorkbook.SaveAs Filename:=wb1.Path & "\" & wbname & ".csv", _
With regards to accessing you sheets by name you can do this,
set sh = ThisWorkBook.Sheets("MILANO")
but since you would want to loop through your sheets anyway, you need have an array with you sheet names like so,
Dim mySheets as Variant
Dim sh as WorkSheet
Dim I as Long
mySheets=Array("MILANO" , "MONACO", "ROME")
For I = 0 to UBound(mySheets)
Set sh = ThisWorkBook.Sheets(mySheets(I))
sh.SaveAs FileName:=ThisWorkBook.Path & "\" & mySheets(I), _
FileFormat:=xlCSV
Next I
So you need to use the WorkSheet.SaveAs and not the WorkBook.SaveAs
as far as "I cannot export only rows of each sheet not-empty as in the CSV I see hundreds of rows with ,,,,,,,,," Perhaps you need to cleanup the Worksheet first
I am trying to create multiple csv files from excel. I have a vba that creates a csv file per tab however there are blanks in the output.
I have 6 columns that the csv file returns is there a way for me to ignore blank cells so I don't have blank commas eg " , , "
Here is the code I am using:
Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "H:\test\"
For Each WS In ThisWorkbook.Worksheet
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
Thanks Joe
Blank cells can be found with Selection.SpecialCells(xlCellTypeBlanks).Select, but I don't see you selecting any data.
If you only need certain columns, I would suggest you remove other columns after copying to your new sheet. Add this line after your Copy:
ActiveSheet.Columns(X).Delete
Do this for each column you want to delete, replacing X with the name of the column, ie. "C".
i have a workbook that i use as a template to make estimates that when i'm done filling out the template there is a macro that creates a new workbook and copies all the sheets of the template workbook to the new one and then removes all the formulas and info i don't want the customer to see.
Here's part of my code that creates the new workbook and copies all the sheets from the template to the new one and then cleans it up
Sub TestConvert()
'Disabling the following to speed up the vba code, must re-enable at end of code
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'adds file name and path to all sheets
Dim WSfn As Worksheet
For Each WSfn In ThisWorkbook.Sheets
'Adds formula to show file path
WSfn.Range("A2") = "=LEFT(CELL(""filename"",RC),FIND(""["",CELL(""filename"",RC),1)-1)"
'Adds formula to show file name
WSfn.Range("A3") = "=MID(CELL(""filename""),FIND(""["",CELL(""filename""))+1,(FIND(""]"",CELL(""filename""))-FIND(""["",CELL(""Filename""))-16))"
WSfn.Calculate 'Calculate sheet
WSfn.Range("A2") = WSfn.Range("A2") 'this will remove the formula from the cell making it text only
WSfn.Range("A3") = WSfn.Range("A3") 'this will remove the formula from the cell making it text only
Next
'************************************************************************************************
'copies all the sheets of the open workbook to a new one
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add 'creates new workbook dimmed as WbTemp
On Error Resume Next 'if there is in error when deleting will not stop the macro from continuing...
'.. deletes the extra sheets 2 sheets if on an older versions of excel
For Each ws In wbTemp.Worksheets
ws.Delete 'deletes all but one sheet in new workbook
Next
On Error GoTo -1 'clears the error handling and sets it to nothing which allows you to create another error trap.
'copys all the sheets from the original to the new workbook dimmed as wbTemp
For Each ws In thisWb.Sheets
ws.Copy After:=wbTemp.Sheets(wbTemp.Worksheets.Count)
Next
wbTemp.Sheets(1).Delete 'deletes the the first sheet in the list in the new workbook which is a black sheet from creating a new workbook
'put vba code to be ran in new book here
'makes all formulas in new workbook values only
wbTemp.Sheets.Select 'selects all sheets in new workbook
Cells.Select 'selects all cell
Selection.Copy 'copies everything selected
Selection.PasteSpecial Paste:=xlPasteValues 'pastes as values only in selected cells
wbTemp.Application.CutCopyMode = False 'clears the clipbored
'removes all defind names from new workbook / submittal
Dim xName As Name
For Each xName In wbTemp.Names
xName.Delete
Next
'removes all dropdowns from new workbook / submittal
Dim DD As Worksheet
For Each DD In wbTemp.Worksheets
Cells.Select
DD.Cells.Validation.Delete
Range("A1").Select
Next
'removes all vba buttons from all sheets
Dim i As Integer
On Error Resume Next
For i = 1 To 1000
wbTemp.Sheets(i).Buttons.Delete
Next i
'All sheets scroll to top left and select "A1"
Dim Sht As Worksheet
'****************************
'change A1 to suit your preference
Const TopLeft As String = "A1"
'****************************
'loop thru all the sheets in the workbook
For Each Sht In Worksheets
'scroll:=True takes cell to the top-left of window
Application.Goto Sheet.Range(TopLeft), scroll:=True
Next
'Hides the following from all sheets
wbTemp.Sheets.Select 'selects all sheets in new workbook
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
'selects the first sheet in the list
Sheets(1).Select
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'save vba code here
'works to only add the filename would like it to also open in file path from cell A2
Application.Dialogs(xlDialogSaveAs).Show Range("A3").Text & "- (Submittal) " & Format(Date, "mm-dd-yy") & "_" & Format(Time, "hhmm") & ".xlsx"
End Sub
im wanting to make it so when the save window opens it opens in the file path from cell A2 and populates the filename from cell A3
i can also send/post the full excel file if that helps any.
The Application.GetSaveAsFilename method is a good choice for this. Pass the return value to a variant type var so you can test for Cancel or Close.
Dim sFN As Variant
With Worksheets("Sheet6")
sFN = .Range("A1") & Chr(92) & .Range("A2") & Format(Date, "_mm-dd-yy") '<~~ no extension yet
End With
With Application
sFN = .GetSaveAsFilename(InitialFileName:=sFN, _
FileFilter:="Excel Workbook (*.xlsx), *.xlsx," & _
"Macro Workbook (*.xlsm), *.xlsm," & _
"Binary Workbook (*.xlsb), *.xlsb")
End With
Select Case sFN
Case False
'user clicked Cancel or Close (×)
Debug.Print sFN
Case Else
With ThisWorkbook
Select Case Right(sFN, 5)
Case ".xlsx"
.SaveAs Filename:=sFN, FileFormat:=xlOpenXMLWorkbook
Case ".xlsm"
.SaveAs Filename:=sFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Case ".xlsb"
.SaveAs Filename:=sFN, FileFormat:=xlExcel12
Case Else
'there really shouldn't be a case else
End Select
End With
End Select
I've added a Select Case statement statement for a Workbook.SaveAs method to three msot common types of Excel workbooks.
You can use the .InitialFileName property of the dialog.
Dim ws As Excel.Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
Dim oFileDialog As FileDialog
Set oFileDialog = Application.FileDialog(msoFileDialogSaveAs)
With oFileDialog
.Title = "Save File"
.ButtonName = "Ok"
.InitialFileName = ws.Range("A2").Value & "\" & ws.Range("A3").Value
.Show
End With
If you need to get back the name that it was saved as you can use .SelectedItems after .Show
MsgBox (oFileDialog.SelectedItems(1))
NOTE:
You probably want to do a quick verification that the directory in A2 exists before doing this. If it does not exist it will throw this into some users folder.
EDIT I'm not sure why yours isn't saving, could be excel version or some other variable in your code.
Since you have the path and name, do you really need the saveas dialog? You could just do
Workbooks.Add
'Then your code in your template that is modifying the active workbook
'Then save it without the dialog
ActiveWorkbook.SaveAs ws.Range("A2").Value & "\" & ws.Range("A3").Value
'OR
ActiveWorkbook.SaveAs Filename:= ws.Range("A2").Value & "\" & ws.Range("A3").Value
I'm trying to copy a sheet in another workbook like this
WB.Sheets("WorkSheet").Copy ThisWorkbook.Sheets(Sheets(Sheets.Count).Select)
So, I want that the copied sheet is the last sheet in my workbook. When I put a 1 in the last bracket it uses always a new sheet, but I want that it copies the sheet always in the same sheet, so overwrites it.
The whole thing look like that:
strPath = ThisWorkbook.Path & "\Subfolder\"
strFile = "copyFile.xlsx"
Application.ScreenUpdating = False
Dim WB As Workbook
Dim Ret
Ret = IsWorkBookOpen(strPath & strFile)
If Ret = True Then
Else
Set WB = Workbooks.Open(strPath & strFile)
End If
WB.Sheets("WorkSheet").Copy ThisWorkbook.Sheets(Sheets(Sheets.Count).Select)
WB.Close False
Application.ScreenUpdating = True
You can use either
WB.Sheets("WorkSheet").Copy **after:=** ThisWorkbook.Sheets(Sheets(Sheets.Count).Select)
Or
WB.Sheets("WorkSheet").Copy ThisWorkbook.Sheets(Sheets(Sheets.Count **+1** ).Select)