SAP Extract into EXCEL via VBA out of memory - excel

I am trying to extract a SAP transaction into a .txt document through a SAP script that I recorded which finally then gets extracted into my excel sheet.
When I run the script in SAP then it works by copying the values into my .txt document. So it seems like my problem is my macro in excel not activating my SAP script.
When I run my VBA macro to do the same, it says
"Run-time error '7': out of memory
and does not copy anything into my .txt document.
I hope someone can tell me why?
Public SapGuiAuto, WScript, msgcol
Public objGui As GuiApplication
Public objConn As GuiConnection
Public objSess As GuiSession
Public objSBar As GuiStatusbar
Public objSheet As Worksheet
Dim W_System
Const fpath = "S:\Supply\WChristian\SAP GUI"
Const ffilename = "script2.txt"
Sub OpenCSVFile()
'
' Load the CSV extract
'
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;S:\Supply\WChristian\SAP GUI\script2.txt", Destination:=Range( _
"$A$4:$I$24"))
.Name = "mb52"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(9, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
Sub DeleteAll()
'
' DeleteAll Macro
On Error Resume Next
Cells.Select
Selection.QueryTable.Delete
Selection.ClearContents
Range("A1").Select
End Sub
Function Attach_Session() As Boolean
Dim il, it
Dim W_conn, W_Sess
If W_System = "" Then
Attach_Session = False
Exit Function
End If
If Not objSess Is Nothing Then
If objSess.Info.SystemName & objSess.Info.Client = W_System Then
Attach_Session = True
Exit Function
End If
End If
If objGui Is Nothing Then
Set SapGuiAuto = GetObject("SAPGUI")
Set objGui = SapGuiAuto.GetScriptingEngine
End If
For il = 0 To objGui.Children.Count - 1
Set W_conn = objGui.Children(il + 0)
For it = 0 To W_conn.Children.Count - 1
Set W_Sess = W_conn.Children(it + 0)
If W_Sess.Info.SystemName & W_Sess.Info.Client = W_System Then
Set objConn = objGui.Children(il + 0)
Set objSess = objConn.Children(it + 0)
Exit For
End If
Next
Next
If objSess Is Nothing Then
MsgBox "No active session to system " + W_System + ", or scripting is not enabled.", vbCritical + vbOKOnly
Attach_Session = False
Exit Function
End If
If IsObject(WScript) Then
WScript.ConnectObject objSess, "on"
WScript.ConnectObject objGui, "on"
End If
Set objSBar = objSess.findById("wnd[0]/sbar")
objSess.findById("wnd[0]").maximize
Attach_Session = True
End Function
Public Sub RunGUIScript()
Dim W_Ret As Boolean
' Connect to SAP
W_Ret = Attach_Session
If Not W_Ret Then
Exit Sub
End If
On Error GoTo myerr
ojbSess.findById("wnd[0]").ResizeWorkingPane 174, 29, False
ojbSess.findById("wnd[0]/tbar[0]/okcd").Text = "mb52"
ojbSess.findById("wnd[0]").sendVKey 0
ojbSess.findById("wnd[0]/usr/ctxtWERKS-LOW").Text = "DO"
ojbSess.findById("wnd[0]/usr/ctxtLGORT-LOW").Text = "01"
ojbSess.findById("wnd[0]/usr/ctxtMATKLA-LOW").Text = "2"
ojbSess.findById("wnd[0]/usr/ctxtMATKLA-LOW").SetFocus
ojbSess.findById("wnd[0]/usr/ctxtMATKLA-LOW").caretPosition = 3
ojbSess.findById("wnd[0]").sendVKey 8
ojbSess.findById("wnd[0]/tbar[1]/btn[45]").press
ojbSess.findById("wnd[1]/tbar[0]/btn[0]").press
ojbSess.findById("wnd[1]/usr/ctxtDY_PATH").Text = "S:\Supply\WChristian\SAP GUI\"
ojbSess.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = "script2.txt"
ojbSess.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 11
ojbSess.findById("wnd[1]/tbar[0]/btn[11]").press
Exit Sub
myerr:
MsgBox "Error occured while retrieving data", vbCritical + vbOKOnly
End Sub
Sub StartExtract()
' Set the sid and client to connect to
W_System = "DCG210"
' Run the GUI script
RunGUIScript
' End the GUI session
' Switch to the worksheet where the data is loaded to
Sheets("Extract").Select
' Delete the entire sheet before loading the file
DeleteAll
' Load the CSV file
OpenCSVFile
' Update the time and date on the control worksheet
Sheets("Control").Select
Cells(2, 2).Value = Now()
End Sub

As I promised #Christian I'm pasting here my approach to connect with SAP. It was always working. I based on that all of my macros for tons of reports from SAP :)
Sub SapConn()
Dim Appl As Object
Dim Connection As Object
Dim session As Object
Dim WshShell As Object
Dim SapGui As Object
'Of course change for your file directory
Shell "C:\Program Files (x86)\SAP\FrontEnd\SAPgui\saplogon.exe", 4
Set WshShell = CreateObject("WScript.Shell")
Do Until WshShell.AppActivate("SAP Logon ")
Application.Wait Now + TimeValue("0:00:01")
Loop
Set WshShell = Nothing
Set SapGui = GetObject("SAPGUI")
Set Appl = SapGui.GetScriptingEngine
Set Connection = Appl.Openconnection("01. PRD - ERP Production", True) 'here paste your name of module you are trying to connect/enter
Set session = Connection.Children(0)
'if You need to pass username and password - not connect automatically
'session.findById("wnd[0]/usr/txtRSYST-MANDT").Text = "900"
'session.findById("wnd[0]/usr/txtRSYST-BNAME").Text = "user"
'session.findById("wnd[0]/usr/pwdRSYST-BCODE").Text = "password"
'session.findById("wnd[0]/usr/txtRSYST-LANGU").Text = "EN"
If session.Children.Count > 1 Then
answer = MsgBox("You've got opened SAP already, please leave and try again", vbOKOnly, "Opened SAP")
session.findById("wnd[1]/usr/radMULTI_LOGON_OPT3").Select
session.findById("wnd[1]/usr/radMULTI_LOGON_OPT3").SetFocus
session.findById("wnd[1]/tbar[0]/btn[0]").press
Exit Sub
End If
session.findById("wnd[0]").maximize
session.findById("wnd[0]").sendVKey 0 'ENTER
'and there goes your code in SAP
Hope it will help You :)

Related

Trouble with this macro :(

I've been trying to program a special user login and Audit Trail, the login makes sheets display in custom order, then I still get
Error 1004: Method of Visible Object Failed.
Help me please :(
Macro 1 (I have 5 sheets in this book, each one has this macro in them):
Private Sub Worksheet_Deactivate()
Me.Name = "Información"
ThisWorkbook.Protect , True
Application.OnTime Now, "UnprotectBook"
End Sub
And Have this one in This Workbook:
Private Sub Workbook_Open()
Application.Visible = False
Sheet1.Visible = True
Sheet2.Visible = False
Sheet3.Visible = False
Sheet4.Visible = False
Sheet5.Visible = False
UF_log.Show
End Sub
Private Sub Workbook_Close()
Sheet1.Visible = False
Sheet2.Visible = False
Sheet3.Visible = False
Sheet4.Visible = False
Sheet5.Visible = False
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.DisplayAlerts = False
ActiveSheet.Delete
MsgBox "No se tiene permitido insertar nuevas hojas de cálculo", vbExclamation, "Alerta"
Application.DisplayAlerts = True
End Sub
UF log code:
Private Sub EnterButton_Click()
Dim Fila, final As Integer
Dim password As Variant
Dim DatoEncontrado
UsuarioExistente = Application.WorksheetFunction.CountIf(Sheets("Users").Range("A:A"), _
Me.TxtUser.Value)
Set Rango = Sheets("Users").Range("A:A")
If Trim(TxtUser.Text) = "" Then
MsgBox "Ingreso Usuario", vbExclamation, "Alerta"
TxtUser.SetFocus
Exit Sub
End If
If Trim(TxtPassword.Text) = "" Then
MsgBox "Ingreso Contraseña", vbExclamation, "Alerta"
TxtPassword.SetFocus
Exit Sub
End If
If UsuarioExistente = 0 Then
MsgBox "El usuario '" & Me.TxtUser & "' no existe", vbExclamation, "Alerta"
Exit Sub
End If
If UsuarioExistente = 1 Then
DatoEncontrado = Rango.Find(What:=Me.TxtUser.Value, MatchCase:=True).Address
Contra = CStr(Sheets("Users").Range(DatoEncontrado).Offset(0, 1).Value)
Estatus = CStr(Sheets("Users").Range(DatoEncontrado).Offset(0, 2).Value)
If Sheets("Users").Range(DatoEncontrado).Value = Me.TxtUser.Value And Contra = Me.TxtPassword.Value Then
MsgBox "Acceso correcto", vbExclamation, "Ok"
If Estatus = "Administrador" Then
Application.Visible = True
Sheet1.Visible = True
Sheet2.Visible = True
Sheet3.Visible = True
Sheet4.Visible = True
Sheet5.Visible = True
Application.CommandBars("Ply").Enabled = True
Call Desproteger
For Fila = 1 To 1000
If Sheet4.Cells(Fila, 1) = "" Then
final = Fila
Exit For
End If
Next
Sheet4.Cells(final, 1) = Application.UserName & " accessed via log in " & " at " & Time & " " & Date
Call Proteger
End
Else
If Estatus = "Fabricación" Then
Application.Visible = True
Sheet1.Visible = True
Sheet2.Visible = xlSheetVeryHidden
Sheet3.Visible = True
Sheet4.Visible = True
Sheet5.Visible = xlSheetVeryHidden
Application.CommandBars("Ply").Enabled = True
Call Desproteger
For Fila = 1 To 1000
If Sheet4.Cells(Fila, 1) = "" Then
final = Fila
Exit For
End If
Next
Sheet4.Cells(final, 1) = Application.UserName & " accessed via log in " & " at " & Time & " " & Date
Call Proteger
End
Else
Application.Visible = True
Sheet1.Visible = True
Sheet2.Visible = True
Sheet3.Visible = xlSheetVeryHidden
Sheet4.Visible = True
Sheet5.Visible = xlSheetVeryHidden
Application.CommandBars("Ply").Enabled = False
Call Desproteger
For Fila = 1 To 1000
If Sheet4.Cells(Fila, 1) = "" Then
final = Fila
Exit For
End If
Next
Sheet4.Cells(final, 1) = Application.UserName & " accessed via log in " & " at " & Time & " " & Date
Call Proteger
End
End If
End If
Else
MsgBox "Datos incorrectos, vuelva a intentar", vbExclamation, "Error"
End If
End If
End Sub
Private Sub ExitButton_Click()
End
End Sub

VBA - Query Table - Getting data from google sheet

I have a function i mostly found on web, to get a table from Google Sheets.
Sub GetDataFromGoogle(wsn As String, address As String)
Dim i As Integer
With Worksheets(wsn)
With .QueryTables.Add(Connection:="URL;" & address, Destination:=.Range("$A$1"))
.PreserveFormatting = False
.BackgroundQuery = True
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
End With
DoEvents
End With
For i = 1 To ThisWorkbook.Connections.Count
If ThisWorkbook.Connections.Count = 0 Then Exit Sub
ThisWorkbook.Connections.item(i).Delete
i = i - 1
Next i
End Sub
It seems to work well, but as i develloped my data base, a problem happened.
I only get the first 100 entries of my google sheet, then i got a empty line, a strange text on the first next range, and then the line under in position 3 the word List
I have no idea of what it is.
Sub Uygula()
Sheets("Veri").Range("A1:D600").ClearContents
Call GetDataFromGoogle("Veri", "18I8Vddjir3lFvtUorMln4mXlYNsY0KZtBGywVreped4")
End Sub
Sub GetDataFromGoogle(wsn As String, adres As String)
Dim i As Integer
Dim qry As String
Dim myURL As String
qry = Application.EncodeURL("SELECT A, C, G, B")
myURL = "https://docs.google.com/spreadsheets/d/" & adres & "/gviz/tq?tqx=out:csv&sheet=1&tq=" & qry
With Worksheets(wsn)
With .QueryTables.Add(Connection:="TEXT;" & myURL, Destination:=.Range("$A$1"))
.Name = "myTable"
.TextFilePlatform = 65001
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
End With
'DoEvents
End With
'For i = 1 To ThisWorkbook.Connections.Count
'If ThisWorkbook.Connections.Count = 0 Then Exit Sub
'ThisWorkbook.Connections.Item(i).Delete
'i = i - 1
'Next i
End Sub

Return newly generated cell value in MsgBox

Whenever I run this code, it generates a sequential number.
I want to display the new sequential number in a MsgBox, but it prints the older sequential number.
Private Sub ToggleButton1_Click()
Dim reponse As VbMsgBoxResult
Dim REVISIONRNCAUTO As Workbook
Dim Sheet2 As Worksheet
Dim cell_value As String
Set REVISIONRNCAUTO = ActiveWorkbook
Set Sheet2 = REVISIONCRNAUTO.Worksheets(2)
cell_value = Sheet2.Cells(4, "A").Value & Sheet2.Cells(4, "B").Value
If CheckBox1.Value = True And CheckBox4.Value = True And CheckBox7.Value = True And CheckBox2.Value = False And CheckBox3.Value = False _
And CheckBox6.Value = False And CheckBox5.Value = False And CheckBox8.Value = False And CheckBox9.Value = False And CheckBox10.Value = False And CheckBox11.Value = False And CheckBox12.Value = False _
And CheckBox13.Value = False And CheckBox14.Value = False And CheckBox15.Value = False Then
Sheet2.Activate
reponse = MsgBox("Êtes-vous sûr de vouloir générer ce RNC?", vbYesNo + vbQuestion, "Enregistrement RNC")
If reponse = vbYes Then
Sheets("Sheet2").Range("B4").Select
ActiveCell.EntireRow.Insert shift:=xlDown
Sheets("Sheet2").Range("B4:E4").Select
Selection.Borders.Weight = xlThin
Sheets("Sheet2").Range("B4").Select
ActiveCell.Value = "=b5+1"
Sheets("Sheet2").Range("A4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = "E"
Else
Exit Sub
End If
End If
MsgBox ("Le nouveau RNC enregistré est le : " & cell_value)
You aren't changing the value of cell_value after you set it.
They are not linked forever like an Excel formula. You have to set it again once you change the cells that it is based on.
Put the cell_value = line right before the Else in addition to where it currently is.

How do I import a dated xls file from the web VBA

I need to import an xls file from the web address https://docs.misoenergy.org/marketreports/YYYYMMDD_sr_nd_is.xls where YYYYMMDD is inputed by the user on another worksheet in the same workbook. In the code below nsiday = 20190316 - 1. I don't know how to actually paste the data in the worksheet I want. I am trying to adapt code that grabs a csv file so that it works for the xls file (https://docs.misoenergy.org/marketreports/YYYYMMDD_rt_lmp_final.csv). I hope that makes sense and thank you all for reading/helping! Note: I haven't included the full csv code I'm trying to adapt.
Option Explicit
Sub NSI()
Dim xday As String
Dim todaystamp As String
Dim nsiday As String
Dim MISORTSht As Worksheet
Dim Selection As Range
Set MISORTSht = Sheet3
MISORTSht.Cells.ClearContents
If MISORTSht.QueryTables.Count > 0 Then
MISORTSht.QueryTables(1).Delete
End If
Dim web As Object
Set web = CreateObject("Microsoft.XMLHTTP")
todaystamp = Format(Sheet1.Cells(6, 1).Value, "yyyymmdd")
xday = Format(Sheet1.Cells(1, 1).Value, "yyyymmdd")
'xday is user defined
nsiday = xday - 1
start:
web.Open "GET", "https://docs.misoenergy.org/marketreports/" & nsiday & "_sr_nd_is" & ".xls", False
web.send
If web.Status = "200" Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With MISORTSht.QueryTables.Add(Connection:="URL;https://docs.misoenergy.org/marketreports/" & nsiday & "_sr_nd_is" & ".xls" _
, Destination:=MISORTSht.Range("A1"))
.Name = "NSI_MISO"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Disregarding the use of QueryTable, you can open online files directly from Excel. Below is an example of how to generate the URL based on a date input and opens it from Excel.
Option Explicit
Private Const DATE_FMT As String = "yyyymmdd"
Private Const BASE_URL As String = "https://docs.misoenergy.org/marketreports/"
Private Const POSTFIX1 As String = "_sr_nd_is.xls"
Private Const POSTFIX2 As String = "_rt_lmp_final.csv"
Sub Main()
Dim dDataDate As Date, dToday As Date, oWB As Workbook
dToday = CDate(ThisWorkbook.Sheets(1).Cells(6, 1).Value) ' Not sure what to do with this
dDataDate = CDate(ThisWorkbook.Sheets(1).Cells(1, 1).Value) - 1 ' 1 day before it
Set oWB = GetOnlineFile(CreateURL1(dDataDate))
If Not oWB Is Nothing Then
' Do whatever you need with the opened file
oWB.Close
Set oWB = Nothing
End If
End Sub
Private Function GetOnlineFile(URL As String) As Workbook
On Error Resume Next
Set GetOnlineFile = Workbooks.Open(URL)
End Function
Private Function CreateURL1(DataDate As Date) As String
CreateURL1 = BASE_URL & Format(DataDate, DATE_FMT) & POSTFIX1
End Function
Private Function CreateURL2(DataDate As Date) As String
CreateURL2 = BASE_URL & Format(DataDate, DATE_FMT) & POSTFIX2
End Function

VBA code error: "out of memory"

i'm currently working on a project where Excel automatically fetches financial data of publicly traded companies.
Sometimes I get the error:"out of memory". Is there a way to fix this?
I'm using 64-bit Excel.
Code:
Sub Get_IS1()
Dim x As Integer
x = 0
execute:
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Set ws = Sheets("Summary")
ws.Activate
Dim qurl, symbol As String
ticker = ws.Range("C9").Value
Exchange = ws.Range("C8").Value
'Delete Prior Connections
For Each cn In ThisWorkbook.Connections
cn.Delete
Next cn
'Clear Prior Data
Sheets("COMP1").Activate
Sheets("COMP1").Cells.Clear
'URL
qurl = "http://financials.morningstar.com/ajax/ReportProcess4CSV.html?&t=" & Exchange & ":" & ticker & "&region=usa&culture=en-US&cur=&reportType=is&period=12&dataType=A&order=asc&columnYear=5&curYearPart=1st5year&rounding=3&view=raw&r=618279&denominatorView=raw&number=3"
'Get Data Via Text File
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & qurl & "" _
, Destination:=Sheets("COMP1").Range("B1"))
.Name = _
"Table 1"
.FieldNames = True
.PreserveFormatting = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
On Error GoTo ends
.Refresh BackgroundQuery:=False
End With
Set ticker = Nothing
Set Exchange = Nothing
Set qurl = Nothing
Set ws = Nothing
Get_BS1
Exit Sub
'Error Handle for Invalid Entry
ends:
x = x + 1
If x = 5 Then
MsgBox ("No response was recived from Morningstar. Either an invalid ticker was entered or no prior records exist for the chosen symbol.")
ws.Activate
ElseIf x < 5 Then
GoTo execute
End If
End Sub
This piece of code fetches the Income Statement, Get_BS1 is called to get the Balance Sheet and after that the Cash Flow Statement
This happens to me when I am attempting to refresh against an empty file. How peculiar that the thing that should use the least memory appears to use the most...
In your case the text is coming from a webpage. You would have to check the result up front before you run your query.
Let's check one thing real quick. Change your connection string to a URL instead of TEXT:
'Get Data Via Text File
With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl & "" _

Resources