I maintain an Excel-workbook with VBA in it.
The VBA fails when fetching a value from a closed Excel-workbook with "ExecuteExcel4Macro".
The workbook to fetch the value from is kept on an intranet-webpage.
GetValue = ExecuteExcel4Macro(arg)
This line of code fails. "Error 2023" is returned.
By tinkering with the code I discovered:
tmp = GetValue(path, file, sheet, ref)
' tmp gets the "Error 2023"-return.
Debug.Print tmp
' Gets the expected data-value from the excel-sheet.
Datum_Homepage = GetValue(path, file, sheet, ref)
If you call it two times the first call gets the "Error 2023" and the second call gets the expected value (a date).
How is that possible?
The complete code of the GetValue-function:
Public Function GetValue(path, file, sheet, ref) As Variant
Dim arg As String
If Right(path, 1) <> "/" Then path = path & "/"
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(ref).Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function
Related
I am trying to figure out how to check that the layout (not the full content) of a CSV file is the same of that in the preceding month (or, if that file doesn't exist, the last available CSV file).
Often companies change the format/layout of their CSV extracts, so I want my code to automatically detect any changes (new columns added, changing order of columns, etc).
Please let me know if you have an idea of how this could be achieved!
Thanks in advance!
Please, try the next code. It assumes that the csv to be compared is comma separated and ending lines are vbCrLf:
Private Sub CheckCSVfile()
Dim ws As Worksheet, strFile As String, ans As VbMsgBoxResult, sep As String
Dim arrRef, arrCSV, cols, i As Long, strProbl As String
ans = MsgBox("Is the active sheet the one you wan to use as reference to compare the CSV file structure?" & vbCrLf & _
"If this is the situation, please press ""Yes""!", vbYesNo, "Confirm the active sheet as reference")
If ans <> vbYes Then Exit Sub
Set ws = ActiveSheet
'Put the first sheet row values in an array (2D array):
arrRef = ws.Range(ws.cells(1, 1), ws.cells(1, ws.cells(1, ws.Columns.count).End(xlToLeft).Column)).value
''Browse for the .csv file to be checked:
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select the csv file to be checked.")
If strFile = "False" Then Exit Sub
'Put the content of the csv file in an array (split by the line ending separator). If not vbCrLf, use the appropriate one:
arrCSV = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(strFile, 1).ReadAll, vbCrLf)
sep = "," 'the csv file separator. Use here the correct one if not comma
cols = Split(arrCSV(0), sep) 'number of columns of the first csv file row (zero based array)
If UBound(cols) + 1 <> UBound(arrRef, 2) Then '+ 1 for the first array because it is of 0 based type
strProbl = strProbl & "The number of columns in the new csv file is different (" & UBound(cols) & " against " & UBound(arrRef) & ")." & vbCrLf
End If
'Comparing each header:
For i = 0 To UBound(arrRef, 2) - 1
If UCase(arrRef(1, i + 1)) <> UCase(cols(i)) Then
strProbl = strProbl & "The value in the column " & i + 1 & " is different (" & cols(i) & " against " & arrRef(1, i + 1) & ")" & vbCrLf
End If
Next i
Stop
If strProbl <> "" Then
MsgBox "The new csv file has a different structure: " & vbCrLf & vbCrLf & strProbl, vbCritical, "Structure problems..."
Else
MsgBox "The both files structure is the same!", vbInformation, "No any structure problem"
End If
End Sub
You must firstly open and activate the sheet of the previous csv file (to be used as reference) and then run the above code.
Please, send some feedback after testing it...
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
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"
Interesting problem here. This line of code works through multiple iterations until it reaches a point where it throws an Run-time error 91 at me: "Object Variable or With block variable not set". This is occurring in a function designed to find a deal number. The entire program is an end of day email generation program that sends attachments to various different counter-parties. The error occurs on the ** line. For additional color, temp deal is not empty when execution is attempted. There doesn't appear to be any extraneous trailing or leading spaces either. Thanks in advance!
Function getPDFs(cFirm As Variant, iFirm As Variant, row_counter As Variant, reportsByFirm As Worksheet, trMaster As Worksheet, trSeparate As Variant, trName As Variant, reportDate As Variant) As String
dealCol = 1
Dim locationArray() As String
Dim DealArray() As String
cDes = "_vs._NY"
iDes = "_vs._IC"
filePath = "X:\Office\Confirm Drop File\"
dealNum = reportsByFirm.Cells(row_counter, dealCol)
FileType = ".pdf"
If InStr(1, dealNum, "-") > 0 Then
DealArray() = Split(dealNum, "-")
tempDeal = DealArray(LBound(DealArray))
Else
tempDeal = dealNum
End If
'Finds deal location in spread sheet for further detail to obtain file path
**trLocation = trMaster.Columns(2).Find(What:=tempDeal).Address
locationArray() = Split(trLocation, "$")
trRow = locationArray(UBound(locationArray))
'Formats client names for 20 characters and removes punctuation (".") in order to stay within convention of file naming
cFirmFormatted = Trim(Left(cFirm, 20))
iFirmFormatted = Trim(Left(iFirm, 20))
'Finds clearing method
clMethod = trMaster.Cells(trRow, 6).Value
Select Case clmethod
Case "Clport"
'Prevents naming convention issues with punctuations in the name
If InStr(1, cFirmFormatted, ".") > 0 Then
cFirmFormatted = Replace(cFirmFormatted, ".", "")
End If
getPDFs = filePath & cFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & cFirmFormatted & cDes & FileType
Case "ICE"
If InStr(1, iFirmFormatted, ".") > 0 Then
iFirmFormatted = Replace(iFirmFormatted, ".", "")
End If
getPDFs = filePath & iFirmFormatted & "\" & reportDate & "_" & dealNum & "_" & iFirmFormatted & iDes & FileType
End Select
End Function
Your code assumes that trLocation is always found, if it isn't found then you will receive an error because you don't have a range to return the .Address property for.
Try testing the result first:
Dim testLocation As Excel.Range
Set testLocation = trMaster.Columns(2).Find(tempDeal)
If Not testLocation Is Nothing Then
trLocation = testLocation.Address
'// Rest of code here...
Else
MsgBox "Cannot find """ & tempDeal & """!"
Exit Function
End If
I have been using InternetExplorer.application with Excel VBA for quite a while with few issues. One problem I have is downloading a file from website. I can get as far as having the "Open/Save As" buttons appear but that is where I am stuck.
I've tried using URLDownloadToFile and it does not seem to work through the same session as the InternetExplorer.application objects that I have. It usually returns the HTML text for a webpage stating that authentication is required. If I have multiple browsers open and some of the old ones are already authenticated then it will download the file most of the time.
Is there a way to download the file using the InternetExplorer.application object itself? If not, is there some way I can associate the URLDownloadtofile function with the object that is already authenticated and logged into the website?
EDIT:
The code I've been using is:
IE2.navigate ("https://...")
strURL = "https://..."
strPath = "c:\..."
Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)
I've also tried:
Do While IE2.Readystate <> 4
DoEvents
Loop
SendKeys "%S"
IE2.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
And:
Dim Report As Variant
Report = Application.GetSaveAsFilename("c:\...", "Excel Files (*.xls), *.xls")
No success in any of these, except for the first one which sometimes saves the actual file, but sometimes saves the website that states the authentication error.
Thanks,
Dave
I have managed to solve similar issue with some JavaScript.
The first step is to make JavaScript download the content of the file into a binary array (it doesn't require another authentication once the user is already authenticated).
Then, I needed to pass this binary array back to VBA. I didn't know the other way, so I print the content of this array into a temporary DIV element (with JavaScript) as a string and then read it with VBA and convert it back to binary array.
Finally, I re-created the file from the given binary array by using ADODB.Stream class.
The time required to download a single file grows geometrically with the size of this file. Therefore, this method is not suitable for large files (> 3MB), since it tooks more than 5 minutes then to download a single file.
Below is the code to do that:
'Parameters:
' * ie - reference to the instance of Internet Explorer, where the user is already authenticated.
' * sourceUrl - URL to the file to be downloaded.
' * destinationPath - where the file should be saved.
'Be aware that the extension of the file given in [destinationPath] parameter must be
'consistent with the format of file being downloaded. Otherwise the function below will
'crash on the line: [.SaveToFile destinationPath, 2]
Public Function saveFile(ie As Object, sourceUrl As String, destinationPath As String)
Dim binData() As Byte
Dim stream As Object
'------------------------------------------------------------------------------------
binData = getDataAsBinaryArray(ie, sourceUrl)
Set stream = VBA.CreateObject("ADODB.Stream")
With stream
.Type = 1
.Open
.write binData
.SaveToFile destinationPath, 2
End With
End Function
Private Function getDataAsBinaryArray(Window As Object, Path As String) As Byte()
Const TEMP_DIV_ID As String = "div_binary_transfer"
'---------------------------------------------------------------------------------------------
Dim strArray() As String
Dim resultDiv As Object
Dim binAsString As String
Dim offset As Integer
Dim i As Long
Dim binArray() As Byte
'---------------------------------------------------------------------------------------------
'Execute JavaScript code created automatically by function [createJsScript] in
'the given Internet Explorer window.
Call Window.Document.parentWindow.execScript(createJsScript(TEMP_DIV_ID, Path), "JavaScript")
'Find the DIV with the given id, read its content to variable [binAsString]
'and then convert it to array strArray - it is declared as String()
'in order to make it possible to use function [VBA.Split].
Set resultDiv = Window.Document.GetElementById(TEMP_DIV_ID)
binAsString = VBA.Left(resultDiv.innerhtml, VBA.Len(resultDiv.innerhtml) - 1)
strArray = VBA.Split(binAsString, ";")
'Convert the strings from the [strArray] back to bytes.
offset = LBound(strArray)
ReDim binArray(0 To (UBound(strArray) - LBound(strArray)))
For i = LBound(binArray) To UBound(binArray)
binArray(i) = VBA.CByte(strArray(i + offset))
Next i
getDataAsBinaryArray = binArray
End Function
'Function to generate JavaScript code doing three tasks:
' - downloading the file with given URL into binary array,
' - creating temporary DIV with id equal to [divId] parameter,
' - writing the content of binary array into this DIV.
Private Function createJsScript(divId As String, url As String) As String
createJsScript = "(function saveBinaryData(){" & vbCrLf & _
"//Create div for holding binary array." & vbCrLf & _
"var d = document.createElement('div');" & vbCrLf & _
"d.id = '" & divId & "';" & vbCrLf & _
"d.style.visibility = 'hidden';" & vbCrLf & _
"document.body.appendChild(d);" & vbCrLf & _
"var req = null;" & vbCrLf & _
"try { req = new XMLHttpRequest(); } catch(e) {}" & vbCrLf & _
"if (!req) try { req = new ActiveXObject('Msxml2.XMLHTTP'); } catch(e) {}" & vbCrLf & _
"if (!req) try { req = new ActiveXObject('Microsoft.XMLHTTP'); } catch(e) {}" & vbCrLf & _
"req.open('GET', '" & url & "', false);" & vbCrLf & _
"req.overrideMimeType('text/plain; charset=x-user-defined');" & vbCrLf & _
"req.send(null);" & vbCrLf & _
"var filestream = req.responseText;" & vbCrLf & _
"var binStream = '';" & vbCrLf & _
"var abyte;" & vbCrLf & _
"for (i = 0; i < filestream.length; i++){" & vbCrLf & _
" abyte = filestream.charCodeAt(i) & 0xff;" & vbCrLf & _
" binStream += (abyte + ';');" & vbCrLf & _
"}" & vbCrLf & _
"d.innerHTML = binStream;" & vbCrLf & _
"})();"
End Function
How about something like this?
Public Sub OpenWebXLS()
' *************************************************
' Define Workbook and Worksheet Variables
' *************************************************
Dim wkbMyWorkbook As Workbook
Dim wkbWebWorkbook As Workbook
Dim wksWebWorkSheet As Worksheet
Set wkbMyWorkbook = ActiveWorkbook
' *************************************************
' Open The Web Workbook
' *************************************************
Workbooks.Open ("http://www.sportsbookreviewsonline.com/scoresoddsarchives/nba/nba%20odds%202015-16.xlsx")
' *************************************************
' Set the Web Workbook and Worksheet Variables
' *************************************************
Set wkbWebWorkbook = ActiveWorkbook
Set wksWebWorkSheet = ActiveSheet
' *************************************************
' Copy The Web Worksheet To My Workbook and Rename
' *************************************************
wksWebWorkSheet.Copy After:=wkbMyWorkbook.Sheets(Sheets.Count)
wkbMyWorkbook.Sheets(ActiveSheet.Name).Name = "MyNewWebSheet"
' *************************************************
' Close the Web Workbook
' *************************************************
wkbMyWorkbook.Activate
wkbWebWorkbook.Close
End Sub