VB excel worksheet not copying to new workbook - excel

struggling to copy a worksheet from source book to destination book.
I've tried 4 different codes found on SO, but running into different errors all the time.
Either: "Copy method failed", "No such interface found", "Exception"- at the copy function.
I know that there are a lot of links and websites referring to the copy method, but i've tried them all and still no luck.
Option Strict = Off
Option Explicit = On
Excel 2016
VS 2019
Sourceworkbook has formatting in and merged cells. Needing the formatting included in the copy method, because I'll be using the new workbooks as back-ups or copies for printing. The sourceworkbook has a template on one of the sheets named "TempPage".
Code:
xlApp1 = New Excel.Application
xlWorkBook1 = xlApp1.Workbooks.Add
'xlWorkSheet1 = CType(xlWorkBook1.Sheets.Add(), Excel.Worksheet)
xlWorkSheet = CType(xlWorkBook.Sheets("TempPage"), Excel.Worksheet) 'Source
xlWorkSheet1 = CType(xlWorkBook1.Sheets("Sheet1"), Excel.Worksheet) 'Destination
'Tried this code
'Dim rngSource As Excel.Range, rngTarget As Excel.Range, targetRow As Long
'rngSource = xlWorkBook.Sheets("TempPage").UsedRange
'With xlWorkBook.Sheets("TempPage")
'targetRow = .UsedRange.SpecialCells(XlCellType.xlCellTypeLastCell).Row + 1
'rngTarget = .cells(targetRow, rngSource.Column)
'End With
'rngSource.Copy(rngTarget)
'Tried this code
'Dim sourceWorkSheet As Excel.Worksheet
'sourceWorkSheet = xlWorkBook.Sheets("TempPage")
'//Copies the source worksheet to the destination workbook, places it after the last
'//sheet in the destination workbook.
'sourceWorkSheet.Copy(, xlWorkBook1.Sheets(xlWorkBook1.Sheets.Count))
'Tried this
'xlWorkSheet.Copy(, xlWorkBook1.Sheets(xlWorkBook1.Sheets.Count))
'tried this
'xlWorkSheet1.Range("A1:I46").Value = xlWorkSheet.Range("A1:I46").Value
'xlWorkSheet.Application.Goto(xlWorkSheet.Range("A1:I46"), True)
'xlWorkSheet.Range("A1:I46").Select()
'xlWorkSheet.Range("A1:I46").Copy()
'xlWorkSheet1.PasteSpecial(Excel.XlPasteType.xlPasteAll,
'Excel.XlPasteSpecialOperation.xlPasteSpecialOperationNone, False, False)
'Tried this
'xlWorkSheet.Range("A1:I46").Copy(xlWorkSheet1.Range("A1:I46"))
'xlWorkSheet1.PasteSpecial(Excel.XlPasteType.xlPasteFormats)
xlWorkBook1.SaveAs(BTPath & "\" & xlWorkSheet.Range("B3").Value & ".xls", Excel.XlFileFormat.xlExcel5) 'save the receipt as the ticket number
If RadioButton3.Checked = True Then
'unpaid - send copy to unpaid folder
xlWorkBook1.SaveAs(UnpaidPath & "\" & xlWorkSheet.Range("B3").Value & ".xls", Excel.XlFileFormat.xlExcel5)
ElseIf RadioButton4.Checked = True Then
End If
I need help with the copying method please.

After a bit more research, found a way to save the worksheet from the source book. Closing the book and reopening the source book for continued usage. Only problem i'm now running into, is that the formulas are still being copied as well and some cells aren't in the same format(bold, merged, size) but found a link on SO - Save values (not formulae) from a sheet to a new workbook?
New code:
'save first
xlWorkBook.Save() 'Save the workbook
Dim newpath As String = BTPath & "\" & xlWorkSheet.Range("B3").Value & ".xls"
xlWorkSheet = CType(xlWorkBook.Sheets("TempPage"), Excel.Worksheet)
xlWorkSheet.Copy()
xlWorkSheet.SaveAs(newpath, Excel.XlFileFormat.xlExcel5)
If RadioButton3.Checked = True Then
'unpaid - send copy to unpaid folder
xlWorkBook.SaveAs(BTPath & "\" & xlWorkSheet.Range("B3").Value & ".xls")
End If
'Close the file and reopen the database file
xlWorkBook.Save() 'Save the workbook
xlWorkBook.Close() 'Close workbook
If xlApp Is Nothing Then
'do nothing
Else
xlApp.Quit() 'Quit the application
End If
GC.Collect()
GC.WaitForPendingFinalizers()
System.Threading.Thread.Sleep(500)
GC.Collect()
GC.WaitForPendingFinalizers()
System.Threading.Thread.Sleep(500)
'reopen
xlApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Open(filepath)
'clear the sheet
xlWorkSheet = CType(xlWorkBook.Sheets("TempPage"), Excel.Worksheet)
xlWorkSheet.Range("D45").Value = ""
xlWorkSheet.Range("B3").Value = ""
xlWorkSheet.Range("B10").Value = ""
xlWorkSheet.Range("F10").Value = ""
xlWorkSheet.Range("F12").Value = ""
xlWorkSheet.Range("B11").Value = ""
xlWorkSheet.Range("F11").Value = ""
xlWorkSheet.Range("I10").Value = ""
xlWorkSheet.Range("A14:H10").Value = ""
'save but don't close
xlWorkBook.Save() 'Save the workbook

Related

Calling VBA Sheet Function (with arguments) from VBS and getting its return value [duplicate]

This question already has answers here:
Run Excel Macro from Outside Excel Using VBScript From Command Line
(8 answers)
Closed 3 months ago.
This post was edited and submitted for review 3 months ago and failed to reopen the post:
Original close reason(s) were not resolved
I am trying to call a VBA function from VBS script:
VBA
Function f_split_master_file(output_folder_path As String, master_excel_file_path As String) As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo ErrorHandler
Dim wb As Workbook
Dim output As String
' Variables related with the master excel file
Dim wb_master As Workbook
Dim ws_master As Worksheet
Dim master_range As Range
Dim responsible_names_range As Range
Dim responsible_name As Range
Dim last_row_master As Integer
' Variables related with the responsible name excel
Dim savepath As String
Dim wb_name As Workbook
Dim ws_name As Worksheet
Dim name As Variant
' Check whether master file exists
If Len(Dir(master_excel_file_path)) = 0 Then ' Master file does not exist
Err.Raise vbObjectError + 513, "Sheet1::f_split_master_file()", "Incorrect Master file path, file does not exist!"
End If
' Check whether output folder exists
If Dir(output_folder_path, vbDirectory) = "" Then ' Output folder path does not exist
Err.Raise vbObjectError + 513, "Sheet1::f_split_master_file()", "Incorrect output folder path, directory does not exist!"
End If
Set wb_master = Workbooks.Open(master_excel_file_path)
Set ws_master = wb_master.Sheets(1)
last_row_master = ws_master.Cells(Rows.Count, "AC").End(xlUp).row
Set master_range = ws_master.Range("A1:AD" & last_row_master)
Set responsible_names_range = ws_master.Range("AC2:AC" & last_row_master) ' Get all names
data = get_unique_responsibles(responsible_names_range) 'Call function to get an array containing distict names (column AC)
For Each name In data
'Create wb with name
savepath = output_folder_path & "\" & name & ".xlsx"
Workbooks.Add
ActiveWorkbook.SaveAs savepath
Set wb_name = ActiveWorkbook
Set ws_name = wb_name.Sheets(1)
master_range.AutoFilter 29, Criteria1:=name, Operator:=xlFilterValues
master_range.SpecialCells(xlCellTypeVisible).Copy
ws_name.Range("A1").PasteSpecial Paste:=xlPasteAll
wb_name.Close SaveChanges:=True
' Remove filters and save workbook
Application.CutCopyMode = False
ws_master.AutoFilterMode = False
Next name
CleanUp:
' Close all wb and enable screen updates and alerts
For Each wb In Workbooks
If wb.name <> ThisWorkbook.name Then
wb.Close
End If
Next wb
Application.ScreenUpdating = True
Application.DisplayAlerts = True
f_split_master_file = output ' empty string if successful execution
Exit Function
ErrorHandler:
' TODO: Log to file
' Err object is reset when it exits from here IMPORTANT!
output = Err.Description
Resume CleanUp
End Function
VBS
Set excelOBJ = CreateObject("Excel.Application")
Set workbookOBJ = excelOBJ.Workbooks.Open("C:\Users\aagir\Desktop\BUDGET_AND_FORECAST\Macro_DoNotDeleteMe_ANDONI.xlsm")
returnValue = excelOBJ.Run("sheet1.f_split_master_file","C:\Users\aagir\Desktop\NON-EXISTENT-DIRECTORY","C:\Users\aagir\Desktop\MasterReport_29092022.xlsx")
workbookOBJ.Close
excelOBJ.Quit
msgbox returnValue
The macro (VBA function) works fine. The only thing that I am missing is within the VBS script. When I call the vba function from vbs script it runs fine but I cannot get the return value in the "returnValue" variable defined in VBS (it does not show anything). Can anyone tell what I am doing wrong? Thanks!
Based on the name sheet1 (in your VBS script), I'm assuming the f_split_master_file Function is in a Worksheet module. Move it to a standard Module and change sheet1 to (eg) Module1 and then try again.

VBA keeps pasting number stores as texts

I'd like VBA to stop copy pasting my top headers with the green ribbon stating "numbers are stores as texts". Is there any way to get around it? I'm trying to copy and paste financial data from another excel sheet onto my main sheet. Here's the Code. Thank you in advance.
Sub God()
'Delete all data from the ranges
ThisWorkbook.Worksheets("10k I").Cells.Clear
ThisWorkbook.Worksheets("10k B").Cells.Clear
ThisWorkbook.Worksheets("10k C").Cells.Clear
ThisWorkbook.Worksheets("10q I").Cells.Clear
ThisWorkbook.Worksheets("10q B").Cells.Clear
ThisWorkbook.Worksheets("10q C").Cells.Clear
'Open workbook Income statement
Workbooks.Open "/Users/krabbysponge/Downloads/1.xls"
Workbooks.Open "/Users/krabbysponge/Downloads/2.xls"
Workbooks.Open "/Users/krabbysponge/Downloads/3.xls"
Workbooks.Open "/Users/krabbysponge/Downloads/4.xls"
Workbooks.Open "/Users/krabbysponge/Downloads/5.xls"
Workbooks.Open "/Users/krabbysponge/Downloads/6.xls"
'Copy range to another workbook
Workbooks("1.xls").Worksheets(1).Range("A1:M150").Copy _
ThisWorkbook.Worksheets("10k I").Range("A1")
Workbooks("2.xls").Worksheets(1).Range("A1:M150").Copy _
ThisWorkbook.Worksheets("10k B").Range("A1")
Workbooks("3.xls").Worksheets(1).Range("A1:M150").Copy _
ThisWorkbook.Worksheets("10k C").Range("A1")
Workbooks("4.xls").Worksheets(1).Range("A1:M150").Copy _
ThisWorkbook.Worksheets("10q I").Range("A1")
Workbooks("5.xls").Worksheets(1).Range("A1:M150").Copy _
ThisWorkbook.Worksheets("10q B").Range("A1")
Workbooks("6.xls").Worksheets(1).Range("A1:M150").Copy _
ThisWorkbook.Worksheets("10q C").Range("A1")
'Close workbook Income statement
Workbooks("1.xls").Close SaveChanges:=True
Workbooks("2.xls").Close SaveChanges:=True
Workbooks("3.xls").Close SaveChanges:=True
Workbooks("4.xls").Close SaveChanges:=True
Workbooks("5.xls").Close SaveChanges:=True
Workbooks("6.xls").Close SaveChanges:=True
End Sub
You don't need to copy - but can write the value direct to the target sheet.
This has two advantages:
you don't use the clipboard
therefore it is much faster
According to "Don't repeat yourself" (DRY) you can put everything in a for-loop - and configuring your files in an array. In case there are changes to this setting it is much easier to adapt the code.
Public Sub copyData()
Dim arrConfig(1, 2) As String
'Target sheetname | Source filename
arrConfig(0, 0) = "10k I": arrConfig(1, 0) = "1.xls"
arrConfig(0, 1) = "10k B": arrConfig(1, 1) = "2.xls"
arrConfig(0, 2) = "10k C": arrConfig(1, 2) = "3.xls"
'...
'arrconfig(0,6) = ...
Const pathDownloads As String = "/Users/krabbysponge/Downloads/"
Const AddressToCopy As String = "A1:M150"
Dim i As Long, wbSource As Workbook, wsSource As Worksheet, wsTarget As Worksheet
For i = 0 To UBound(arrConfig, 2)
Set wsTarget = ThisWorkbook.Worksheets(arrConfig(0, i))
wsTarget.Cells.Clear
Set wbSource = Workbooks.Open(pathDownloads & arrConfig(1, i))
Set wsSource = wbSource.Worksheets(1)
'This is the part where the data are written from one range to another (values only without formatting)
wsTarget.Range(AddressToCopy).Value = wsSource.Range(AddressToCopy).Value
wbSource.Close savechanges:=True
Next
End Sub

Subscript Out of Range Error because no ReDim?

Not sure why I am getting this error. Please assist in correcting and also, provide a good explanation for the reason. I have 3 subs (from 2 modules) that call each other sequentially. Is the reason for the error message because the file name from the first sub is declared as a variable in the third sub? See code below:
Module1:
Option Explicit
Sub PRM_1_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_1_New As Workbook ' This is BCRS-PTASKS Unassigned.csv
Set PRM_1_New = Workbooks("BCRS-PTASKS Unassigned.csv")
Dim SaveDir1 As String, prmAfn As String
SaveDir1 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir1, vbDirectory)) = 0 Then MkDir SaveDir1
prmAfn = SaveDir1 & "\PRM_1_TEMP"
Application.SendKeys ("~")
PRM_1_New.SaveAs Filename:=prmAfn, FileFormat:=xlOpenXMLWorkbook
PRM_1_New.Close False
Call PRM_2_Report_Save
Application.ScreenUpdating = True
End Sub
Sub PRM_2_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_2_New As Workbook ' This is Problem WGM & WGL xref with description.xls
Set PRM_2_New = Workbooks("Problem WGM & WGL xref with description.xls")
Dim SaveDir2 As String, prmBfn As String
SaveDir2 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir2, vbDirectory)) = 0 Then MkDir SaveDir2
prmBfn = SaveDir2 & "\PRM_2_TEMP"
Application.SendKeys ("~")
PRM_2_New.SaveAs Filename:=prmBfn, FileFormat:=xlOpenXMLWorkbook
PRM_2_New.Close False
Application.ScreenUpdating = True
Call Open_PRM_Files
End Sub
Module 2:
Option Explicit
Sub Open_PRM_Files()
'
Application.ScreenUpdating = False
Dim PRM_Dir As String
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
Application.ScreenUpdating = True
End Sub
This line from the sub in Module2 is where the debugger shows the error (which is also commented in the sub above):
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
The purpose of the code here is to save two imported reports into .xlsx format, close them, and then open the files in the saved format. I need this to occur in separate subs (save and open) for other workflow processes of this VBA Project not listed (or relevant) here.
EDIT: I should also mention that the first two subs execute and provide the intended results which is each file saved in the new directory and with the proper extension.
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
This line assumes that you already have an open workbook with that name. If Excel does not find an open workbook with that name then you will get a runtime error as you noticed.
I'm assuming that you are trying to open the workbooks here which you created in the first two subs:
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
"& PRM_1_TEMP" is the name of a Workbook variable, and you're trying to concatenate it as a string name. Change this to a string matching the filename, and then move your declarations of workbooks to below the code that opens the workbooks. This way Excel opens the workbooks BEFORE trying to access them in the Workbooks collection, and you should not receive an error. I haven't tested this modification, but please let me know if it works for you.
Sub Open_PRM_Files()
Application.ScreenUpdating = False
Dim PRM_Dir As String
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_1_TEMP"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_2_TEMP"
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
Application.ScreenUpdating = True
End Sub

Refresh values from external sheet on background

I have two sheets, where I need to refresh values (function VLOOKUP) from source.xlsm to update.xlsm ON BACKGROUND by VBA (only manual refresh by button with assigned macro - I do not want to use update button in Excel options).
I have found two codes, which complete this task, however, the source.xlsm always pops up for a second while the task is made. I would like to have the task completed without the source file being visible on the screen.
Any ideas?
Sub Read_External_Sheet()
'''''Define Object for Target Workbook
Dim Target_Workbook As Workbook
Dim Source_Workbook As Workbook
Dim Target_Path As String
'''''Assign the Workbook File Name along with its Path
'''''Change path of the Target File name
Target_Path = "D:\Source.xlsm"
Set Target_Workbook = Workbooks.Open(Target_Path)
Set Source_Workbook = ThisWorkbook
'''''With Target_Workbook object now, it is possible to pull any data from it
'''''Read Data from Target File
Target_Data = Target_Workbook.Sheets(1).Cells(1, 1)
DoEvents
Source_Workbook.Sheets(1).Cells(1, 1) = Target_Data
DoEvents
'''''Update Target File
Source_data = Source_Workbook.Sheets(1).Cells(3, 1)
DoEvents
Target_Workbook.Sheets(1).Cells(2, 1) = Source_data
DoEvents
'''''Close Target Workbook
Target_Workbook.Close False
'''''Process Completed
MsgBox "SHEET UPDATED"
End Sub
Sub Read_External_Sheet_2()
Dim FName As Workbook
With Application
.EnableEvents = False
Set FName = .Workbooks.Open("D:\Source.xlsm", False)
mybook = FName.Name
With FName
.RefreshAll
.Close True 'save file
End With
.EnableEvents = True
End With
msg = MsgBox(mybook & " Refreshed")
End Sub

copy a sheet from a workbook without opening to another [duplicate]

I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.

Resources