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)
Related
As pre-warning, I am new to using VBA.
I have scraped together the following code to do the following:
1. Locate the worksheet "Intrastat"
2. Copy the used range of this worksheet
3. Paste as values into a new workbook
4. Reformat dates in column B
5. Save the workbook with in the original workbook's location.
However this only works when I have the macro saved in the original workbook. What I need is to be able to have the macro saved in a different workbook and on running the macro I need to be able to select the "original" workbook from a file location on my HDD.
Any ideas?
The Current Code:
Sub TB_Intrastat_Data_Cleanse()
Dim wb As Workbook
Set wb = Workbooks.Add
Set TWKB = ThisWorkbook
Set sel = Selection
Dim folderPath As String
folderPath = Application.ThisWorkbook.Path
TWKB.Sheets("Intrastat").UsedRange.Copy
wb.Sheets(1).[a1].PasteSpecial xlPasteValues
Columns("B:B").Select
Selection.NumberFormat = "dd/mm/yyyy;#"
nme = "TB Intrastat Data " & Range("A3") & " MTD"
ActiveWorkbook.SaveAs Filename:=folderPath & nme
End Sub
You can use Application.GetOpenFilename() to prompt the user to browse through the file explorer, and open a file. It will then use that file as TWKB:
Sub TB_Intrastat_Data_Cleanse()
Dim wb As Workbook, TWKB As Workbook
Dim sel As Range
Dim nme As String
Set wb = Workbooks.Add
Set TWKB = Application.GetOpenFilename(Title:="Please choose a file to open", FileFilter:="Excel Files *.xls* (*.xls*),")
Set sel = Selection
Dim folderPath As String
folderPath = Application.ThisWorkbook.Path
TWKB.Sheets("Intrastat").UsedRange.Copy
wb.Sheets(1).[a1].PasteSpecial xlPasteValues
Columns("B:B").NumberFormat = "dd/mm/yyyy;#"
nme = "TB Intrastat Data " & Range("A3") & " MTD"
ActiveWorkbook.SaveAs Filename:=folderPath & nme
End Sub
Note: I would change ActiveWorkbook.SaveAs at the end to a workbook variable (or explicitly name the workbook), since you're using two separate ones you want to make sure it's saving the correct one.
right now I am trying to create an excel macro which should copy one worksheet from my workbook. This worksheet should be saved as a new Excel file named with the value from cell B1.
Everything works fine so far.
The problem is: I want that the copy is a back-up. So the values in the table (copy) should not be connected to the original table.
So to make it short: I just want to copy format+values but not the formulas from the table.
Do you have any ideas how I can make this work?
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim FName As String
Dim FPath As String
Dim wbkExport As Workbook
Dim shtToExport As Worksheet
FPath = "C:\Users\User\Desktop\Artikelnummern"
FName = Worksheets("Test").Cells(1, 2).Value
Set shtToExport = ThisWorkbook.Worksheets("Test")
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False 'Possibly overwrite
without asking
wbkExport.SaveAs Filename:=FPath & "\" & FName & ".xlsx"
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False
End Sub
Replace your line:
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
With:
shtToExport.Cells.Copy
wbkExport.Worksheets(wbkExport.Worksheets.Count - 1).Range("A1").PasteSpecial xlPasteValues
wbkExport.Worksheets(wbkExport.Worksheets.Count - 1).Range("A1").PasteSpecial xlPasteFormats
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 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
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "c:\Vouchers\"
fileName = Dir(directory & "*.csv??")
Do While fileName <> ""
Workbooks.Open (directory & fileName)
For Each sheet In Workbooks(fileName).Worksheets
total = Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.Count
Workbooks(fileName).Worksheets(sheet.Name).Copy _
after:=Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets(total)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The above code gets all the data I need but creates a new sheet for each workbook, is there anyway to place the data from the first workbook in row 10 then add the data from the next workbook in the next available row?
Give this a try. Note, you may have to adjust the value of your Dest worksheet, I've defined it the best I could based on your code.
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim Dest as Worksheet
Dim DestRow as long
Dim Source as Workbook
'adjust this as necessary - it should create a new sheet at the end of
'"Voucher Report...", and call it "My New Sheet"
Set Dest = Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.add _
after:=Workbooks("Voucher Report 26MAR V1.0.xlsm").Worksheets.Count _
Name:="My New Sheet"
DestRow = 10
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "c:\Vouchers\"
fileName = Dir(directory & "*.csv??")
Do While fileName <> ""
'assign the opened workbook to a var for easier use
set source = Workbooks.Open (directory & fileName)
For Each sheet In source.Worksheets
'copy the UsedRange cells from the sheet
'.copy is kind of weird, but this works
sheet.cells(1,1).resize(sheet.usedrange.rows.count, sheet.usedrange.columns.count).copy
'paste doesn't apply to a range, but to a worksheet object
' the destination param tells it where to go
dest.paste destination:=range(cells(destrow,"A")
'increment the current row pointer but the number of rows used
destrow = destrow + sheet.usedrange.rows.count
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
All code untested, so you may have some minor tweaks. I'd suggest commenting out the ScreenUpdating lines until you have it all working correctly.
Note: I found the references for .copy here in the MS Docs, and for .paste here in the MS Docs.