The goal is to open another Excel file with parameters from first / main file and call macro who creates 1 or n new sheets with data from database, but Excel won't create new sheets in second file and then all other logic fails.
You can find sample code for two files below. When B file is opened manually and called tst() sub, this works, but not when first file opens second file. Workbooks are not protected, I'm using MS Excel 2010.
A_file.xlsm is main file where user calls GetFile to open another file and run ReadParams macro. Code is located in modules.
Sub GetFile(fileName As String)
Dim filePath, par1, par2, currentUser As String
Dim targetFile As Workbook
currentUser = CreateObject("WScript.Network").UserName
filePath = "C:\Users\" & currentUser & "\Documents\Excel_APPS\"
par1 = "USE_R_one"
par2 = "some_val"
Application.ScreenUpdating = False
Set targetFile = Workbooks.Open(filePath & "B_file.xlsm")
Application.Run "'" & targetFile.Name & "'!ReadParams(" & Chr(34) & par1 & Chr(34) & ", " & Chr(34) & par2 & Chr(34) & ")"
targetFile.Activate
Application.ScreenUpdating = True
End Sub
B_file.xlsm macros:
Sub ReadParams(s_uno As String, s_duo As String)
If IsNull(s_uno) Or IsNull(s_duo) Then
MsgBox "Error occurred.", vbExclamation, "Error"
Else
MsgBox "All params are ok, new sheet is coming right after this msg"
ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Sheet_Data" '<-- THIS WON'T WORK
End If
End Sub
Sub tst()
ReadParams "USE_R", "test"
End Sub
The problem is in the line Application.Run...
The syntax for this is
Application.Run "'b.xlsm'!ReadParams", par1, par2
You had your parameters concatenated to the first argument
Related
I have this userform
It is fully fuctioning but I want to add a feature that is sending the file as .xlsx or .txt so I can remove the macro from the file.
I searched the internet for days and come up to a procedure that I need to make a 3 process to save it to another format. The process I come up is listed below:
1. .SaveCopyAs
Copy(Filename).(Same format)
.Open
Existing File
.SaveAs
(FileName).(Any format)
And delete the SaveCopyAs file to avoid redundancy Or catch the temporary file to SaveAs another file format? Every input should be save after clicking ok button and to overwrite the existing file.
Can someone tell me if I'm making the right approach to my problem? Thanks.
I have had a similar issue, my solution involved copying the Sheets into a new workbook then renaming them accordingly and saving that workbook with a specific name:
ans = MsgBox("Would you like to export the Report?", vbYesNo)
Select Case ans
Case vbYes
FPath = "C:\...\...\... Daily Report"
FName = "Report" & ".xlsx"
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("Sheet2").Copy Before:=NewBook.Sheets(1)
ThisWorkbook.Sheets("Sheet3").Copy Before:=NewBook.Sheets(1)
Application.DisplayAlerts = False
'NewBook.Sheets("Sheet1").Delete to delete the first empty sheet on the new workbook
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName
End If
NewBook.Close False
CurrentReport = FPath & "\" & FName
Case vbNo
Exit Sub
End Select
Or to append the data to a text file, each time the user clicks "OK":
Sub VBA_to_append_existing_text_file()
Dim strFile_Path As String
strFile_Path = "C:\temp\test.txt" ‘Change as per your test folder and exiting file path to append it.
Open strFile_Path For Append As #1
Write #1, "This is my sample text" ' add entered data here
Close #1
End Sub
Working with Office 2013, I am trying to insert VBA code to automatically enter the employee name as it is displayed in the top right hand corner of any Office product into cell B2 upon them opening up the excel spreadsheet. The current code I am using is
Sub Auto_Open()
Range("B2").Value = " " & Application.UserName
End Sub
However, this just makes it display "Authorized User".
What am I doing wrong?
I poked around at this morning. I figured this information must be stored somewhere in the registry if it isn't accessible as part of the Excel object model. This makes sense, especially if this username is part of a corporate subscription.
The Registry Key
I did a search in the registry for how my username showed up in Excel, and this popped up.
The FriendlyName is exactly how my username shows up in Excel. So all we need now is a method to read this registry key's FriendlyName, and that should do it :)
Code
Here is some code that works for me based on the location of this key. It may be slightly different on your computer, so you may need to tweak this to find the FriendlyName
Private Function GetFriendlyName() As String
On Error GoTo ErrorHandler:
Const HKEY_CURRENT_USER = &H80000001
Const ComputerName As String = "."
Dim CPU As Object
Dim RegistryKeyPath As String
Dim RegistrySubKeys() As Variant
Dim RegistryValues() As Variant
Dim SubKeyName As Variant
Dim SubKeyValue As Variant
Dim KeyPath As String
GetFriendlyName = vbNullString
Set CPU = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\root\default:StdRegProv")
'Specify where to look
RegistryKeyPath = "Software\Microsoft\Office\" & Application.Version & "\Common\Identity\Identities"
'Enumerate the registry keys
CPU.EnumKey HKEY_CURRENT_USER, RegistryKeyPath, RegistrySubKeys
'Iterate each key in the identities folder
For Each SubKeyName In RegistrySubKeys
'Get each value in that folder
CPU.EnumValues HKEY_CURRENT_USER, RegistryKeyPath & "\" & SubKeyName, RegistryValues
'Go through each value, and find the Friendly Name
For Each SubKeyValue In RegistryValues
If SubKeyValue = "FriendlyName" Then
KeyPath = "HKEY_CURRENT_USER\" & RegistryKeyPath & "\" & SubKeyName & "\" & SubKeyValue
'Read the key
With CreateObject("Wscript.Shell")
GetFriendlyName = .RegRead(KeyPath)
End With
Exit Function
End If
Next
Next
CleanExit:
Exit Function
ErrorHandler:
'Handle errors here
Resume CleanExit
End Function
'Run this to see the output in the immediate window
Private Sub ExampleUsage()
Debug.Print "The friendly name is: " & GetFriendlyName
End Sub
Results
The friendly name is: Ryan A. Wildry
Try this:
Sub Auto_Open()
Dim Username As String
Dim path As String
Dim sourcefile As String
Dim objFso As FileSystemObject
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FileExists(path & " ~$" & sourcefile) Then
Username = Split(GetFileOwner(path, " ~$" & sourcefile), "\")(1)
Range("B2").Value = " " & Username
Else
MsgBox ("File not Found!")
End If
End Sub
I'm stepping through the code to export a module using this post, but nothing happens. Is there a security setting to allow VBA permission to export a module?
I'm copying a few tabs from a workbook into a new workbook, but the tabs have macros which lead to broken links. To get around this I want to move the module and re-associate the macro. If I can't get this to work I will just copy the whole workbook and delete the info I don't want in the destination.
Here's the code from the above post:
Public Sub CopyModule(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)
' Description: copies a module from one workbook to another
' example: CopyModule Workbooks(ThisWorkbook), "Module2",
' Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm")
' Notes: If Module to be copied already exists, it is removed first,
' and afterwards copied
Dim strFolder As String
Dim strTempFile As String
Dim FName As String
If Trim(strModuleName) = vbNullString Then
Exit Sub
End If
If TargetWB Is Nothing Then
MsgBox "Error: Target Workbook " & TargetWB.Name & " doesn't exist (or closed)", vbCritical
Exit Sub
End If
strFolder = SourceWB.Path
If Len(strFolder) = 0 Then strFolder = CurDir
' create temp file and copy "Module2" into it
strFolder = strFolder & "\"
strTempFile = strFolder & "~tmpexport.bas"
On Error Resume Next
FName = Environ("Temp") & "\" & strModuleName & ".bas"
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
Err.Clear
Kill FName
If Err.Number <> 0 Then
MsgBox "Error copying module " & strModuleName & " from Workbook " & SourceWB.Name & " to Workbook " & TargetWB.Name, vbInformation
Exit Sub
End If
End If
' remove "Module2" if already exits in destination workbook
With TargetWB.VBProject.VBComponents
.Remove .Item(strModuleName)
End With
' copy "Module2" from temp file to destination workbook
SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
TargetWB.VBProject.VBComponents.Import strTempFile
Kill strTempFile
On Error GoTo 0
End Sub
I am trying to write a macro that copies data from multiple external workbooks to a single workbook in a certain order. I do not intend to have each workbook be open for my macro to work, as that would be an outrageous number of open spreadsheets, so I did a Google search and came across this nifty function, the GetValue function:
http://spreadsheetpage.com/index.php/tip/a_vba_function_to_get_a_value_from_a_closed_file/
Just to set myself up for the rest of the code, I made a code that is supposed to simply take a single piece of data from a cell of an external workbook, and put it in a single cell of the workbook and sheet I'm currently in. In the current worksheet, I stuck the file paths of the workbooks I want access into the B column, and the file names in the A column, since there are so many and I want to be able to access each in a single code. Here is that code:
Sub Gather_Data()
Dim p As String
Dim f As String
Dim s As String
Dim a As String
p = Range("B7").Value
f = Range("A7").Value
s = Sheet5
a = D7
Cells(10, 10).Value = GetValue(p, f, s, a).Value
End Sub
Private Function GetValue(path, file, sheet, ref)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
I don't see anything wrong with the code, but whenever I try to run it I get a run-time error that states, "Method 'Range' of object '_Global' failed". I honestly have no idea what that means and running the debugger highlights the
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
area, which I didn't even write. If anyone has experience using this function or knows how to resolve this error, your input would be greatly appreciated. Thanks in advance!
Your variables are declared as String, so try changing your code from this:
s = Sheet5
a = D7
To this:
s = "Sheet5"
a = "D7"
I need help copying data from a closed workbooks (without opening them) into a column in the master workbook using VBA. I keep getting the error:
Run-time Error 424: object required
Here is my code:
Set x = Workbooks.Open("C:\Users\DD\Desktop\EMS")
x.Sheets("PO Report").Range("Y3:Y500").Copy
y.Activate
Sheets("Sheet1").Range("Q2").PasteSpecial
Application.CutCopyMode = False
x.Close
Thanks for the help in advance!
this is the problem - you are not specifying the filename of the excel file
Set x = Workbooks.Open("C:\Users\DD\Desktop\EMS")
you cannot read data out of a closed file... it has to be open
you also need to Dim your x object
Dim x as object
I altered the code posted here. Insert the following code in your "Sheet1" sheet module:
Option Explicit
Sub GetDataDemo()
Dim FilePath$
Dim i As Long
Const FileName$ = "EMS.xlsx"
Const SheetName$ = "PO Report"
FilePath = "C:\Users\DD\Desktop\"
DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For i = 3 To 500
Range("Q" & i - 1) = GetData(FilePath, FileName, SheetName, Range("Y" & i))
Next i
ActiveWindow.DisplayZeros = False
End Sub
Private Function GetData(Path, File, Sheet, Rng)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & Rng.Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function