Code macro Excel
y
Bonjour,
Je souhaite savoir si il est possible de copier un code d'une macro Access qui extrait des données depuis SAP dans une macro Excel. Si oui faut il laisser le code identique ou y'aura des parties a modifier.
Merci
Invité
Bonjour yh20 bonne année 2020 et
Une petite présentation ICI serait la bienvenue
Si vous ne l'avez pas encore fait, je vous invite à lire la charte du forum [A LIRE AVANT DE POSTER] ainsi que ses fonctionnalités
qui vous aideront dans vos demandes et réponses sur ce forum.
Concernant votre demande, sans avoir le code (à mettre entre balises avec le bouton </>) il est vraiment compliqué de vous répondre
Pour moi le code pour extraire les données doit les mettre dans une table, cela n'existe pas dans Excel, il faudra donc, je suppose, le modifier.
Merci de votre participation
Cordialement
y
Bonsoir Bruno,
Merci pour ta réponse ! C'est bon pour la charte et la présentation.
Concernant le code il y'a trois modules dans l'ordre ci dessous
Public Sub PrepareClipboard()
Dim myRecordset As dao.Recordset
Dim f As dao.Field
Dim myFileSystemObject As Object
Dim txtfile As Object
Dim PathAddressLocalExport$
Dim pathClipboard$
PathAddressLocalExport = DLookup("VariableValue", "tb_GlobalPath", "VariableName = 'LocalExportFolder'")
pathClipboard = PathAddressLocalExport & "clipboard.txt"
'Kill old Clipboard file
If Len(Dir(pathClipboard)) <> 0 Then
SetAttr pathClipboard, vbNormal
Kill pathClipboard
End If
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set txtfile = myFileSystemObject.CreateTextFile(pathClipboard, True)
strClipboard = "SELECT DISTINCT Format([tb_CHANGE_LOG].[ChangeObjectValue]," & Chr(34) & "000000000000000000" & Chr(34) & ") AS ChangeObjectValue FROM [tb_CHANGE_LOG]"
Set myRecordset = CurrentDb.OpenRecordset(strClipboard)
'Begin row processing
With myRecordset
For Each f In .Fields
Do While Not .EOF
txtfile.Write (f.Value)
txtfile.WriteLine
.MoveNext
Loop
Next
.Close
End With
txtfile.Close
Set myRecordset = Nothing
End Sub
Public Sub TRANSFER_CHANGE_LOG_TO_DATABASE()
Dim Excel_Workbook As String
Dim Excel_Worksheet As String
Dim PathAddressLocalExport$
PathAddressLocalExport = DLookup("VariableValue", "tb_GlobalPath", "VariableName = 'LocalExportFolder'")
'Clear Input tables just to be sure there is nothing inside
strDelete = "DELETE * FROM tb_CHANGE_LOG"
CurrentDb.Execute strDelete
'Assign excel objects
Excel_Workbook = PathAddressLocalExport & "CHANGE_LOG.xlsx"
Excel_Worksheet = "[CHANGE_LOG$]"
'check if existing
If Len(Dir(Excel_Workbook)) <> 0 Then
'Create queries as string
strSQL_Access = "INSERT INTO tb_CHANGE_LOG "
strSQL_Excel = "SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & Excel_Workbook & "]." & Excel_Worksheet
strSQL = strSQL_Access & strSQL_Excel
'Run upload to ms access
CurrentDb.Execute strSQL
End If
End Sub
Public Sub CHECK_IF_OBJECTS_PROVIDED()
Count = DCount("*", "tb_CHANGE_LOG")
If Count = 0 Then
MsgBox "Please provide material numbers in column [ChangeObjectValue] and click RUN again", vbInformation
End
End If
End Sub
Public Sub UPDATE_APPLICATION_OBJECT_CHANGE()
'perform query update
strUpdate = "UPDATE tb_CHANGE_LOG INNER JOIN tb_ApplicationObjectChange ON tb_CHANGE_LOG.ApplicationObjectChangeFlag = tb_ApplicationObjectChange.ApplicationObjectChangeName SET [tb_CHANGE_LOG].[ApplicationObjectChangeFlag] = tb_ApplicationObjectChange.ApplicationObjectChangeDescription;"
CurrentDb.Execute strUpdate
'refresh form view
Form_UserForm.Refresh
End Sub
Public Sub TRANSFER_CHANGE_LOG_TXT_FILE_TO_DATABASE()
Dim PathAddressLocalExport$
PathAddressLocalExport = DLookup("VariableValue", "tb_GlobalPath", "VariableName = 'LocalExportFolder'")
'Run import from txt file to ms access table
''DoCmd.RunSavedImportExport "Import-CHANGE_LOG"
DoCmd.TransferText transferType:=acImportDelim, SpecificationName:="CHANGE_LOG Import Specification", TableName:="tb_CHANGE_LOG", FileName:=PathAddressLocalExport & "CHANGE_LOG.txt", hasfieldnames:=True
'Delete empty lines from table
'strDeleteEmpty = "DELETE tb_CHANGE_LOG.ChangeObjectValue, tb_SPEEDO_CHNG_PS.DocNo, tb_SPEEDO_CHNG_PS.TableKey, tb_SPEEDO_CHNG_PS.FieldName, tb_SPEEDO_CHNG_PS.OldValue, tb_SPEEDO_CHNG_PS.NewValue FROM tb_SPEEDO_CHNG_PS WHERE ChangeObjectValue.ChangeObjectValue=" & Chr(34) & Chr(34) & " Or ChangeObjectValue.ChangeObjectValue Is Null"
strDeleteEmpty = "DELETE * FROM tb_CHANGE_LOG WHERE tb_CHANGE_LOG.ChangeObjectValue=" & Chr(34) & Chr(34) & " Or tb_CHANGE_LOG.ChangeObjectValue Is Null or tb_CHANGE_LOG.ChangeUser=" & Chr(34) & Chr(34) & " or tb_CHANGE_LOG.ChangeUser is Null"
CurrentDb.Execute strDeleteEmpty
End Sub
Public Sub delete_Empty_Lines_CHANGE_LOG_TXT()
Const FOR_READING = 1
Const FOR_WRITING = 2
sPath = DLookup("VariableValue", "tb_GlobalPath", "VariableName = 'LocalExportFolder'")
strFileName = sPath & "CHANGE_LOG.txt"
iNumberOfLinesToDelete = 4
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objTS = objFS.OpenTextFile(strFileName, FOR_READING)
strContents = objTS.ReadAll
objTS.Close
arrLines = Split(strContents, vbNewLine)
Set objTS = objFS.OpenTextFile(strFileName, FOR_WRITING)
For i = 0 To UBound(arrLines)
If i > (iNumberOfLinesToDelete - 1) Then
objTS.WriteLine arrLines(i)
End If
Next
End Sub
Public Sub checkDirectory()
Dim sFilePath As String
Dim sNetworkDrivePath As String
'Assign directories
sFilePath = CurrentProject.Path
sNetworkDrivePath = "\MDM\Operations\CDP Tools"
'Close current Db
If InStr(1, sFilePath, sNetworkDrivePath) > 0 And Len(sFilePath) > 0 And Len(sNetworkDrivePath) > 0 Then
MsgBox "You are using file directly from: " & sFilePath & vbNewLine & "Please make your local copy. File will be closed now.", vbCritical
DoCmd.CloseDatabase
End If
End SubOption Compare Database
Public sPath As String
Public Function pathData(myPath As String) As String
Dim objFileDialog As Object
'--- Add \ at the end of path if needed ---
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
Else
myPath = myPath
End If
'--- Check received path ---
On Error Resume Next
If Len(Dir(myPath, vbDirectory)) > 0 Then
If Err.Number = 52 Then
On Error GoTo -1
On Error GoTo 0
GoTo FilePicker
Else
On Error GoTo -1
On Error GoTo 0
End If
End If
If Len(Dir(myPath, vbDirectory)) > 0 Then
pathData = myPath
'--- Stay with current path ---
ElseIf Not (Len(Dir(sPath, vbDirectory)) > 0) Then
FilePicker:
MsgBox "Please choose the folder path where the temporary files used by the tool will be saved."
'--- Ask to choose new path ---
Set objFileDialog = Application.FileDialog(4) '4 = msoFileDialogFolderPicker
With objFileDialog
.AllowMultiSelect = False
.ButtonName = "Choose this path"
.Title = "File dialog folder picker"
If (.Show > 0) Then
End If
If (.SelectedItems.Count > 0) Then
'--- Assign new path ---
pathData = .SelectedItems(1) & "\"
'--- Check if new path is not too long ---
If Len(pathData) > 200 Then
MsgBox "The choosen path is too long for current usage." & vbNewLine & _
"Please run the code again and choose the shorter path (the current limit is 200 characters)." & vbNewLine & _
"All next procedures were terminated. Tool will be closed now." & vbNewLine & _
"Please reopen the file if you would like to retry this action.", vbCritical
DoCmd.CloseDatabase
End
End If
ElseIf (.SelectedItems.Count = 0) Then
'--- Terminate current function and all next functions ---
MsgBox "File dialog folder picker was terminated by the user." & vbNewLine & _
"All next procedures were terminated. Tool will be closed now." & vbNewLine & _
"Please reopen the file if you would like to retry this action.", vbCritical
DoCmd.CloseDatabase
End
End If
End With
End If
End FunctionPublic Sub check_SAP_logon() 'check SAP logon
GoTo SAP_check_logon
SAP_connection_failed:
MsgBox "SAP connection failed. Please check your connection to S1P and try again. Macro will be stopped.", vbInformation, "Ooops..."
End
SAP_check_logon:
On Error GoTo SAP_connection_failed
If Not IsObject(sapApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set sapApplication = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(sapconnection) Then
Set sapconnection = sapApplication.Children(0)
End If
If Not IsObject(session) Then
Set session = sapconnection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject Application, "on"
End If
'-------------------------------------------------------
End Sub
Sub query_area() 'choose query area
If Not IsObject(sapApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set sapApplication = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(sapconnection) Then
Set sapconnection = sapApplication.Children(0)
End If
If Not IsObject(session) Then
Set session = sapconnection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject Application, "on"
End If
With session
.findById("wnd[0]/tbar[0]/okcd").Text = "/nsq00"
.findById("wnd[0]").sendVKey 0
If Not .findById("wnd[0]/usr/txtRS38R-WSTEXT").Text = "Standard Area (Client-specific)" Then 'check if standard query area already open
.findById("wnd[0]/mbar/menu[5]/menu[0]").SELECT
.findById("wnd[1]/usr/radRAD1").SELECT
.findById("wnd[1]/tbar[0]/btn[2]").press
End If
If Not InStr(1, .findById("wnd[0]/titl").Text, " MDM_OPS:") > 0 Then 'if MDM_OPS query group already open
.findById("wnd[0]/mbar/menu[1]/menu[7]").SELECT
.findById("wnd[1]/usr/cntlGRID1/shellcont/shell").currentCellRow = -1
.findById("wnd[1]/usr/cntlGRID1/shellcont/shell").selectColumn "DBGBNUM"
.findById("wnd[1]/tbar[0]/btn[29]").press
.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "MDM_OPS"
.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 7
.findById("wnd[2]/tbar[0]/btn[0]").press
.findById("wnd[1]/usr/cntlGRID1/shellcont/shell").selectedRows = "0"
.findById("wnd[1]/tbar[0]/btn[0]").press
End If
End With
End Sub
Public Sub SAP_QUERY_CHANGE_LOG()
Dim clipboard$
' Dim CHANGE_LOG_xls$
' Dim CHANGE_LOG_xlsx$
Dim CHANGE_LOG_txt$
' Dim xlApp As Object
' Dim sheet As Object
Dim PathAddressLocalExport$
PathAddressLocalExport = DLookup("VariableValue", "tb_GlobalPath", "VariableName = 'LocalExportFolder'")
clipboard = "clipboard.txt"
' CHANGE_LOG_xls = "CHANGE_LOG.xls"
' CHANGE_LOG_xlsx = "CHANGE_LOG.xlsx"
CHANGE_LOG_txt = "CHANGE_LOG.txt"
Call query_area
If Not IsObject(sapApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set sapApplication = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(sapconnection) Then
Set sapconnection = sapApplication.Children(0)
End If
If Not IsObject(session) Then
Set session = sapconnection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject Application, "on"
End If
With session
.findById("wnd[0]/usr/ctxtRS38R-QNUM").Text = "CHANGE_LOG"
'with variant
'.findById("wnd[0]/tbar[1]/btn[17]").press
'.findById("wnd[1]/usr/ctxtRS38R-VARIANT").Text = "" 'wpisac variant
'.findById("wnd[1]/tbar[0]/btn[0]").press
'without variant
.findById("wnd[0]/tbar[1]/btn[8]").press
.findById("wnd[0]/usr/txtSP$00001-LOW").Text = "" 'Object value low
.findById("wnd[0]/usr/txtSP$00001-HIGH").Text = "" 'Object value high
.findById("wnd[0]/usr/btn%_SP$00001_%_APP_%-VALU_PUSH").press
'IMPORT_FROM_TXT_FILE
.findById("wnd[1]/tbar[0]/btn[23]").press 'import from txt file
.findById("wnd[2]/usr/ctxtDY_PATH").Text = PathAddressLocalExport 'from
.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = clipboard 'file
.findById("wnd[2]/tbar[0]/btn[0]").press 'confirm
.findById("wnd[1]/tbar[0]/btn[8]").press 'F8 - execute
.findById("wnd[0]/usr/txtSP$00002-LOW").Text = Nz(Form_UserForm.txt_SapUser, "") 'User name low
.findById("wnd[0]/usr/txtSP$00002-HIGH").Text = "" 'User name high
.findById("wnd[0]/usr/ctxtSP$00003-LOW").Text = Format(Nz(Form_UserForm.txt_ChangeDateStart, ""), "dd.mm.yyyy") 'Creation date low
.findById("wnd[0]/usr/ctxtSP$00003-HIGH").Text = Format(Nz(Form_UserForm.txt_ChangeDateEnd, ""), "dd.mm.yyyy") 'Creation date high
.findById("wnd[0]/usr/ctxtSP$00004-LOW").Text = "" 'Time changed low
.findById("wnd[0]/usr/ctxtSP$00004-HIGH").Text = "" 'Time changed high
.findById("wnd[0]/usr/ctxtSP$00005-LOW").Text = "" 'Tcode low
.findById("wnd[0]/usr/ctxtSP$00005-HIGH").Text = "" 'Tcode high
.findById("wnd[0]/usr/txtSP$00006-LOW").Text = Nz(Form_UserForm.cbx_TableName.Column(0), "") 'Table Name low
.findById("wnd[0]/usr/txtSP$00006-HIGH").Text = "" 'Table Name high
.findById("wnd[0]/usr/ctxtSP$00008-LOW").Text = Nz(Form_UserForm.cbx_ApplicationObjectChange.Column(1), "") 'Change type (U, I, E, D) low
.findById("wnd[0]/usr/ctxtSP$00008-HIGH").Text = "" 'Change type (U, I, E, D) high
.findById("wnd[0]/usr/txtSP$00007-LOW").Text = "" 'Field Name low
.findById("wnd[0]/usr/txtSP$00007-HIGH").Text = "" 'Field Name high
.findById("wnd[0]/usr/txtSP$00009-LOW").Text = Nz(Form_UserForm.cbx_ChangeLogObject.Column(1), "") 'Object Class low
.findById("wnd[0]/usr/txtSP$00009-HIGH").Text = "" 'Object Class high
.findById("wnd[0]/tbar[1]/btn[8]").press
End With
If session.findById("wnd[0]/sbar").Text = "No data was selected" Then GoTo quit_sq00 'prevent error if no values found
session.findById("wnd[0]/usr/cntlCONTAINER/shellcont/shell").pressToolbarContextButton "&MB_EXPORT"
session.findById("wnd[0]/usr/cntlCONTAINER/shellcont/shell").selectContextMenuItem "&PC"
session.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").SELECT
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ctxtDY_PATH").Text = PathAddressLocalExport
session.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = CHANGE_LOG_txt
session.findById("wnd[1]/tbar[0]/btn[11]").press
GoTo continue
quit_sq00:
'----------------------------------
session.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
session.findById("wnd[0]").sendVKey 0
MsgBox "No hits found in S1P.", vbExclamation
End
continue:
'----------------------------------
session.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
session.findById("wnd[0]").sendVKey 0
' Set xlApp = CreateObject("Excel.Application")
' xlApp.Visible = True
' xlApp.workbooks.Open (PathAddressLocalExport & CHANGE_LOG_xls)
' Set sheet = xlApp.workbooks(CHANGE_LOG_xls).sheets(1)
'
' With sheet
' .SELECT
' .Columns("A").Delete
' .Columns("B").Delete
' .rows("1:4").Delete
' .rows(2).Delete
' .Columns("C").Replace What:=".", Replacement:="/"
' .Columns("C").NumberFormat = "dd/mm/yyyy"
' .Columns("J").NumberFormat = "@"
' .Columns("K").NumberFormat = "@"
'
' End With
'
' 'xlApp.ActiveWorkbook.Close SaveChanges:=True
' xlApp.Application.Displayalerts = False
' xlApp.ActiveWorkbook.saveAs FileName:=PathAddressLocalExport & CHANGE_LOG_xlsx, FileFormat:=51, CreateBackup:=False
' xlApp.Application.ActiveWorkbook.Close
' xlApp.Application.Displayalerts = True
' Set sheet = Nothing
' xlApp.Visible = False
' xlApp.Quit
' Set xlApp = Nothing
End Sub