目录
启用 SAP脚本
1.使用前“脚本录制和回放”的功能是要开启状态。如果没开启是要找管理员开启。
2.点击后红色按钮开启录制
3.此时可以在SAP里进行手动操作，可以记录下用户操作的脚本。
录制完之后可以点击关闭。再点击“更多”。
4.可以把这个Script1.vbs这个复制到桌面，把后缀名改成txt
如下是进入MM03查询了某个料号的脚本。
Tracker
进入SAP后，启用Tracker，点击这个
图标。可以查询程式里字段的ID。
如物料的ID是
wnd[0]/usr/tabsTABSPR1/tabpSP01/ssubTABFRA1:SAPLMGMM:2004/subSUB1:SAPLMGD1:1002/ctxtRMMG1-MATNR
Excel启用VBA
勾选“开发工具”
点击“宏安全性”
点击“启用所有宏”。关闭EXCEL再打开即可。
点击“Visual Basic”
进入后点击插入
点击插入模块
在编辑界面输入SUB，命名程序后回车
可以复制录制脚本的代码进去，点击执行即可
录制的这个部分是VBS的内容，不能在EXCEL里执行，要改下。
对象声明
改成的这个如果没进入SAP的话会报错，并要调试。
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
如果没进SAP的话，改成MsgBox提醒错误
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
On Error Resume Next
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
If Err > 0 Then
MsgBox "请检查是否登入SAP", vbExclamation
Exit Sub
End If
On Error GoTo 0定义函数直接调用，更方便
Public session As Object
Function MyConnectSAP() As Boolean
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object
On Error Resume Next
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
If Err > 0 Then
MsgBox "请检查是否登入SAP", vbExclamation
MyConnectSAP = True
Else
MyConnectSAP = False
End If
Set SapGuiAuto = Nothing
Set AppSap = Nothing
Set Connection = Nothing
End Function
用法
TEXT文本
在栏位里输入文本，例如
session.findById("wnd[0]/tbar[0]/okcd").Text = "/NCKM3N"Press点击
点击，例如：
session.findById("wnd[0]/tbar[1]/btn[13]").pressKey选择
选择，例如：
session.findById("wnd[0]/usr/cmbMLKEY-CURTP").Key = "10"Selected复选框
可以操作复选框，TRUE表示勾选，FALSE表示不勾选
session.findById("wnd[0]/usr/chkPA_XKONS").Selected = False判断字段是否存在
如下是判断某个字段确实存在，删去Not表示判断某个字段确实不存在
If Not session.findById("wnd[2]/usr/txtMESSTXT1", False) Is Nothing Then
End IfVerticalScrollbar 滑动滚动条
16代表一次滑动16个栏位
session.findById("wnd[1]/usr/tblSAPLMGMMTC_VIEW").verticalScrollbar.Position = 16Enter
输入Enter键
session.findById("wnd[0]").sendVKey 0粘贴剪贴板
先声明了字典d，在Excel中取值（此处省略了这个部分），然后通过“多项选择”，除去重复值后，粘贴到剪贴板中
Dim objData As New MSForms.DataObject, d As Object
Dim objData As New MSForms.DataObject
With session
.findById("wnd[0]/usr/btn%_SO_WERKS_%_APP_%-VALU_PUSH").press '点击
objData.SetText Join(d.keys, Chr(13) & Chr(10))
objData.PutInClipboard '复制到剪贴板中
.findById("wnd[1]/tbar[0]/btn[16]").press '删除整个选择
.findById("wnd[1]/tbar[0]/btn[24]").press '自剪切板上载
.findById("wnd[1]/tbar[0]/btn[8]").press '点击
d.RemoveAll '删除
End With读取shell
'读取shell时不同于text，要通过循环取值
'把取到的shell赋值给Table
'Table.RowCount表示总行数
'Table.ColumnCount表示总列数
'Table.ColumnOrder可以取列名
'Table.getcellvalue 可以取表的值
'例如此处把取到的Table传到了数组arr里，然后在读取到Excel中
Dim x As Integer, y As Integer, k As Integer, arr(), Title()
ReDim arr(1 To 100000, 1 To 15)
ReDim Title(1 To 15)
With session
Set Table = .findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell")
Set Columns = Table.ColumnOrder() '取列
For x = 0 To Table.RowCount() - 1 'Table.RowCount表示为总行数
k = k + 1
For y = 0 To Table.ColumnCount() - 1
arr(k, y + 1) = Table.getcellvalue(x, CStr(Columns(y))) '取值
Next y
Next x
For y = 0 To Table.ColumnCount() - 1
Title(y + 1) = CStr(Columns(y)) 'Columns返回标题文本
Next y
End With读取shell[1]
'读取shell[1]里隐藏的内容时需要打开节点
'Table.GetAllNodeKeys 表示所有的节点，返回值是数字
'Table.expandNode 打开节点
'Table.GetAllNodeKeys.Count 表示总节点数
'Table.getitemtext 可以获取内容
Dim Table As Object, GetNodeK As Object, arr(), i As Integer, x
'进入程式获取节点
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NFS00"
.findById("wnd[0]").sendVKey 0 'Enter
Set Table = .findById("wnd[0]/shellcont/shell/shellcont[1]/shell[1]")
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
End With
'打开所有节点
For x = GetNodeK.Count - 1 To 0 Step -1
Table.expandNode GetNodeK.Item(x)
Next x
'重新读取shell[1]
Set Table = session.findById("wnd[0]/shellcont/shell/shellcont[1]/shell[1]")
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
For x = 0 To GetNodeK.Count - 1
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = GetNodeK.Item(x) '节点
arr(i) = Table.getitemtext(arr(i), "&Hierarchy") '获得内容
Next xVBS登入SAP
VBS登入SAP开发区110
这个能不能成功运行，主要还是靠SendKeys操作键盘，让SAP弹出输入密码的界面，网络延迟，或者SAP Logon不是当时的选择的状态的话都有可能登不上。
Dim wsh
Set wsh = CreateObject("Wscript.shell")
'如果路径中带空格需要用chr(34)&"path"& chr(34)包起来
wsh.Run Chr(34) & "C:\Program Files (x86)\SAP\FrontEnd\SAPgui\saplogon.exe" & Chr(34)
wscript.sleep 500
wsh.SendKeys "~"
wscript.sleep 2000
If Not IsObject(Application) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set Application = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(Connection) Then
Set Connection = Application.Children(0)
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
If IsObject(wscript) Then
wscript.ConnectObject session, "on"
wscript.ConnectObject Application, "on"
End If
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/usr/txtRSYST-MANDT").Text = "110"
.findById("wnd[0]/usr/txtRSYST-BNAME").Text = "C10089213"
.findById("wnd[0]/usr/pwdRSYST-BCODE").Text = "" '密码
.findById("wnd[0]").sendVKey 0
End With
实例
函数-提取Tcode
Function MyGetSAPtCode() As String
If MyConnectSAP() Then Exit Function
Application.Volatile
MyGetSAPtCode = session.findById("wnd[0]/sbar/pane[1]").Text
Set session = Nothing
End Function登入开发区
Sub 登入110()
Shell "C:\Program Files (x86)\SAP\FrontEnd\SAPgui\saplogon.exe", vbNormalFocus
Application.Wait (Now() + TimeValue("00:00:02"))
SendKeys "~"
Application.Wait (Now() + TimeValue("00:00:04")) '如果系统反应不过来的话后面会赋值不到，有必要的话可以延长时间
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/usr/txtRSYST-MANDT").Text = "110"
.findById("wnd[0]/usr/txtRSYST-BNAME").Text = "C10089213"
.findById("wnd[0]/usr/pwdRSYST-BCODE").Text = "" '密码
.findById("wnd[0]").sendVKey 0
End With
End SubCO03
CO03中批量查询研发工单的信息
Sub CO03_显示_结算规则()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示CO03？" & Chr(10) & " " & Chr(10), vbYesNo, "CO03")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, y As Integer, sr As String, rg As Range, arr1(), i As Integer, bl As Boolean
Dim Table As Object, Columns As Object
ReDim arr2(1 To 1000, 1 To 10)
sr = "CO03"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
For x = 2 To UBound(arr1)
If arr1(x, 1) = "" Then Exit For
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NCO03"
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtCAUFVD-AUFNR").Text = arr1(x, 1) '工单
.findById("wnd[0]").sendVKey 0 '
arr2(x - 1, 1) = "'" & .findById("wnd[0]/usr/ctxtCAUFVD-WERKS").Text '工厂
.findById("wnd[0]/usr/tabsTABSTRIP_0115/tabpVERW").Select '管理
arr2(x - 1, 2) = .findById("wnd[0]/usr/tabsTABSTRIP_0115/tabpVERW/ssubSUBSCR_0115:SAPLCOKO1:0170/txtCAUFVD-ERNAM").Text '创建
arr2(x - 1, 3) = .findById("wnd[0]/usr/tabsTABSTRIP_0115/tabpVERW/ssubSUBSCR_0115:SAPLCOKO1:0170/txtCAUFVD-AENAM").Text '更改
.findById("wnd[0]/mbar/menu[4]/menu[3]").Select '结算规则
arr2(x - 1, 4) = .findById("wnd[0]/usr/tblSAPLKOBSTC_RULES/ctxtCOBRB-KONTY[0,1]").Text 'CTR
.findById("wnd[0]").sendVKey 2 '进入结算规则里
arr2(x - 1, 5) = .findById("wnd[0]/usr/subBLOCK1:SAPLKOBS:0200/txtCOBR_INFO-OBJ_TEXT").Text ' 工单说明
arr2(x - 1, 6) = .findById("wnd[0]/usr/subBLOCK2:SAPLKACB:1014/ctxtCOBL-KOSTL").Text '成本中心
arr2(x - 1, 7) = .findById("wnd[0]/usr/subBLOCK2:SAPLKACB:1014/ctxtCOBL-PS_POSID").Text 'WBS元素
arr2(x - 1, 8) = .findById("wnd[0]/usr/subBLOCK2:SAPLKACB:1014/ctxtCOBL-SAKNR").Text '总账科目
arr2(x - 1, 9) = .findById("wnd[0]/usr/subBLOCK2:SAPLKACB:1014/ctxtCOBL-PRCTR").Text '利润中心
arr2(x - 1, 10) = .findById("wnd[0]/usr/txtCOBRB-PROZS").Text '百分比
Next x
End With
With ThisWorkbook.Sheets("CO03")
.AutoFilterMode = False
With .Cells(1, 2)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = Split("工厂;创建人;更改人;CTR;工单说明;成本中心;WBS元素;总账科目;利润中心;百分比", ";")
.Cells(2, 1).Resize(UBound(arr1), UBound(arr2, 2)) = arr2
End With
End With
End Sub
MM03
MM03查询标估价等
Sub MM03_显示物料()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示物料？" & Chr(10) & " " & Chr(10), vbYesNo, "MM03")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, y As Integer, sr As String, rg As Range, arr1(), k As Integer, i As Integer, j As Integer, bl As Boolean
Dim Table As Object, Columns As Object
ReDim arr2(1 To 10000, 1 To 20)
sr = "MM03"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
bl = False
With session
For x = 2 To UBound(arr1)
If arr1(x, 1) = "" Then Exit For
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NMM03"
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRMMG1-MATNR").Text = arr1(x, 2) '查询物料
.findById("wnd[0]").sendVKey 0
i = 0
j = 0
Do
i = i + 1
sr = "wnd[1]/usr/tblSAPLMGMMTC_VIEW/txtMSICHTAUSW-DYTXT[0," & i & "]"
If .findById(sr, False) Is Nothing Then
bl = True
Exit Do
Else
If .findById(sr).Text = "会计 1" Then
.findById("wnd[1]/usr/tblSAPLMGMMTC_VIEW").getAbsoluteRow(j * 16 + i).Selected = True
.findById("wnd[1]/tbar[0]/btn[0]").press
Exit Do
End If
End If
If i Mod 16 = 0 Then '选择视图最大有16个栏位， 超过要下滑滚动条
.findById("wnd[1]/usr/tblSAPLMGMMTC_VIEW").verticalScrollbar.Position = 16
i = 0
j = j + 1
End If
Loop
If .findById("wnd[0]/sbar/pane[0]").Text <> "" Then '物料查不到下面会有一个警告冒出来
bl = True
Else
sr = "wnd[2]/tbar[0]/btn[0]"
If Not session.findById(sr, False) Is Nothing Then '测试区没有这个错误提示，正式区有
.findById(sr).press '输入工厂前有个错误提示要确定
End If
.findById("wnd[1]/usr/ctxtRMMG1-WERKS").Text = arr1(x, 1)
.findById("wnd[1]/tbar[0]/btn[0]").press
If Not .findById("wnd[2]/usr/txtMESSTXT1", False) Is Nothing Then '查不到某个工厂的物料会有个警告
bl = True
Else
arr2(x - 1, 4) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP25/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2800/subSUB1:SAPLCKMMAT:0010/tabsTABS/tabpPPLF").Text '会计期间
arr2(x - 1, 5) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP25/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2800/subSUB1:SAPLCKMMAT:0010/tabsTABS/tabpPPLF/ssubSUBML:SAPLCKMMAT:0100/subSUBCURR:SAPLCKMMAT:0200/txtCKMMAT_DISPLAY-STPRS_1").Text '公司代码货币 标准价格
arr2(x - 1, 6) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP25/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2800/subSUB1:SAPLCKMMAT:0010/tabsTABS/tabpPPLF/ssubSUBML:SAPLCKMMAT:0100/subSUBCURR:SAPLCKMMAT:0200/txtCKMMAT_DISPLAY-PEINH_1").Text '公司代码货币 价格单位
arr2(x - 1, 7) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP25/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2800/subSUB1:SAPLCKMMAT:0010/tabsTABS/tabpPPLF/ssubSUBML:SAPLCKMMAT:0100/subSUBCURR:SAPLCKMMAT:0200/txtCKMMAT_DISPLAY-STPRS_2").Text '集团公司记帐货币，利润中心评估
arr2(x - 1, 8) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP25/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2800/subSUB1:SAPLCKMMAT:0010/tabsTABS/tabpPPLF/ssubSUBML:SAPLCKMMAT:0100/subSUBCURR:SAPLCKMMAT:0200/txtCKMMAT_DISPLAY-PEINH_2").Text '集团公司记帐货币，利润中心评估 价格单位
.findById("wnd[0]/usr/tabsTABSPR1/tabpSP28").Select '成本核算2
arr2(x - 1, 1) = "'" & .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB1:SAPLMGD1:1009/ctxtRMMG1-WERKS").Text '工厂
arr2(x - 1, 2) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB1:SAPLMGD1:1009/ctxtRMMG1-MATNR").Text '物料
arr2(x - 1, 3) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB1:SAPLMGD1:1009/txtMAKT-MAKTX").Text '描述
arr2(x - 1, 9) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-PDATL").Text '会计年度
arr2(x - 1, 10) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-PPRDL").Text '期间
arr2(x - 1, 11) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB4:SAPLMGD1:2902/ctxtMBEW-BKLAS").Text '评估类
arr2(x - 1, 12) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB4:SAPLMGD1:2902/ctxtMBEW-VPRSV").Text '价格控制
arr2(x - 1, 13) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB4:SAPLMGD1:2902/txtMBEW-PEINH").Text '价格单位
arr2(x - 1, 14) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-LPLPR").Text '计划价格
arr2(x - 1, 15) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-STPRS").Text '标准价格
arr2(x - 1, 16) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB3:SAPLMGD1:2952/txtMBEW-ZPLP1").Text '计划价格1
arr2(x - 1, 17) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB3:SAPLMGD1:2952/ctxtMBEW-ZPLD1").Text '计划价格日期1
arr2(x - 1, 18) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-PPRDZ").Text '将来期间
arr2(x - 1, 19) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-PDATZ").Text '将来年份
arr2(x - 1, 20) = .findById("wnd[0]/usr/tabsTABSPR1/tabpSP28/ssubTABFRA1:SAPLMGMM:2000/subSUB2:SAPLMGD1:2953/txtMBEW-ZPLPR").Text '将来价格
End If
End If
Next x
End With
With ThisWorkbook.Sheets("MM03")
.AutoFilterMode = False
With .Cells(1, 3)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = Split("工厂;物料;描述;会计期间;公司标准价;公司价格单位;利润中心标准价;利润中心价格单位;会计年度;期间;评估类;价格控制;价格单位;计划价格;标准价格;计划价格1;计划价格日期1;将来期间;将来年份;将来价格", ";")
.Cells(2, 1).Resize(UBound(arr1), UBound(arr2, 2)) = arr2
End With
End With
If bl Then
MsgBox "注意！有物料没查到！"
Else
MsgBox "成功"
End If
End SubCS15
CS15查询多个料号的BOM
Sub CS15_单层反查清单_多层()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示 CS15？" & Chr(10) & " " & Chr(10), vbYesNo, "CS15 - 单层反查清单")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, y As Integer, z As Integer, sr As String, rg As Range, arr1(), k As Integer, brr(), bl As Boolean
Dim Table As Object, Columns As Object
ReDim arr2(1 To 100000, 1 To 15) '此处要提前知道列数，并且加了一列 'Table.ColumnCount()
ReDim brr(1 To 15)
sr = "CS15"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
brr(1) = "物料"
With session
For z = 2 To UBound(arr1)
If arr1(z, 1) = "" Then Exit For
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NCS15"
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRC29L-DATUV").Text = TheTime(0, "yyyy.mm.dd")
.findById("wnd[0]/usr/ctxtRC29L-MATNR").Text = arr1(z, 2) '物料
.findById("wnd[0]/usr/chkRC29L-DIRKT").Selected = True
.findById("wnd[0]/tbar[1]/btn[5]").press
.findById("wnd[0]/usr/ctxtRC29L-WERKS").Text = arr1(z, 1) '工厂
.findById("wnd[0]/usr/chkRC29L-MEHRS").Selected = True '多层
.findById("wnd[0]/tbar[1]/btn[8]").press
If .findById("wnd[0]/sbar/pane[0]").Text <> "" Then
bl = True
k = k + 1
arr2(k, 1) = arr1(z, 2)
arr2(k, 4) = arr1(z, 1)
arr2(k, 5) = .findById("wnd[0]/sbar/pane[0]").Text
Else
Set Table = .findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell")
Set Columns = Table.ColumnOrder()
For x = 0 To Table.RowCount() - 1
k = k + 1
arr2(k, 1) = arr1(z, 2)
For y = 0 To Table.ColumnCount() - 1
arr2(k, y + 2) = Table.getcellvalue(x, CStr(Columns(y)))
Next y
If x Mod 39 = 0 Then 'bom 测试是每39行后要刷一次屏，否则导出的数据是空白
Table.SetCurrentCell x, CStr(Columns(0))
Table.firstVisibleRow = x
End If
Next x
For y = 0 To Table.ColumnCount() - 1
brr(y + 2) = CStr(Columns(y)) '目前关闭
Next y
End If
Next z
End With
For x = 1 To k
arr2(x, 4) = "'" & arr2(x, 4)
Next x
With ThisWorkbook.Sheets("CS15")
.AutoFilterMode = False
With .Cells(1, 3)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = brr '目前没用
.Resize(1, UBound(arr2, 2)) = Split("物料;级别;物料清单用途;工厂;对象;对象标识;备选物料清单;项目编号;超出需求数量;需求数量;组件计量单位;ResQ excess;重计划数量;基本计量单位;对象描述", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr2, 2)) = arr2
End With
End With
If bl Then
MsgBox "注意！有部分没有查到！"
Else
MsgBox "成功"
End If
End SubTEST
测试运行，读取Shell
Sub test()
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim Table As Object, Columns As Object
Dim x As Integer, y As Integer, k As Integer, arr(), Title()
ReDim arr(1 To 100000, 1 To 15)
ReDim Title(1 To 15)
With session
Set Table = .findById("wnd[0]/usr/cntlFDBL_BALANCE_CONTAINER/shellcont/shell") '把表shell赋值给Table
Set Columns = Table.ColumnOrder() '取列
For x = 0 To Table.RowCount() - 1 'Table.RowCount表示为总行数
k = k + 1
For y = 0 To Table.ColumnCount() - 1 'Table.ColumnCount表示总列数Table.ColumnCount
arr(k, y + 1) = Table.getcellvalue(x, CStr(Columns(y))) '取值
Next y
Next x
For y = 0 To Table.ColumnCount() - 1
Title(y + 1) = CStr(Columns(y)) 'Columns返回标题文本
Next y
End With
With ThisWorkbook.Sheets("test")
.AutoFilterMode = False
.Cells.ClearContents
.Cells(1, 1).Resize(1, UBound(arr, 2)) = Title
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr, 2)) = arr
End With
End SubKS13
KS13用Excel导出的方式批量读取成本中心
Sub KS13_显示成本中心()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示成本中心？" & Chr(10) & " " & Chr(10), vbYesNo, "KS13")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Long, y As Integer, z As Integer, sr As String, rg As Range, bl As Boolean, wb As Workbook, j As Integer
Dim arr1(), arr2(), arr3(), k As Long
ReDim arr3(1 To 100000, 1 To 23)
sr = "KS13"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
Call KillSapPath
With session
For z = 2 To UBound(arr1)
If arr1(z, 1) = "" Then Exit For
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKS13"
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/subKOSTL_SELECTION:SAPLKMS1:0100/radKMAS_D-KZKOSTL").Select
.findById("wnd[0]/usr/subKOSTL_SELECTION:SAPLKMS1:0100/ctxtKMAS_D-KOSTL").Text = "" '成本中心
.findById("wnd[0]/usr/subKOSTL_SELECTION:SAPLKMS1:0100/radKMAS_D-KZVARIANT").Select
.findById("wnd[0]/usr/subKOSTL_SELECTION:SAPLKMS1:0100/ctxtKMAS_D-VARIANT_KS").Text = "" '选择变式
.findById("wnd[0]/usr/ctxtCSKSZ-DATAB_ANFO").Text = TheTime(0, "yyyy.mm.01")
.findById("wnd[0]/usr/subKOSTL_SELECTION:SAPLKMS1:0100/radKMAS_D-KZKOSTLSET").Select
.findById("wnd[0]/usr/subKOSTL_SELECTION:SAPLKMS1:0100/ctxtKMAS_D-KOSTL_SET").Text = arr1(z, 1) '成本中心组
.findById("wnd[0]/tbar[1]/btn[8]").press '执行
bl = True
sr = "wnd[0]/sbar/pane[0]"
If .findById(sr, False) Is Nothing Then
If Right(.findById(sr), 3) <> "不存在" Then
bl = False
End If
End If
If bl Then
If Not .findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell", False) Is Nothing Then
.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").contextMenu
.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectContextMenuItem "&XXL"
.findById("wnd[1]/tbar[0]/btn[0]").press
.findById("wnd[1]/usr/ctxtDY_PATH").Text = SapPath()
j = j + 1 '每次命名的文件不一致
.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = j & ".XLSX"
.findById("wnd[1]/tbar[0]/btn[0]").press
Set wb = Workbooks.Open(SapPath() & "/" & j & ".XLSX") '对文件取值
arr2 = wb.Sheets(1).Range("A1").CurrentRegion.Value
wb.Close
Set wb = Nothing
For x = 2 To UBound(arr2)
k = k + 1
arr3(k, 1) = arr1(z, 1)
For y = 1 To UBound(arr2, 2)
arr3(k, y + 1) = arr2(x, y)
Next y
Next x
End If
End If
Next z
End With
With ThisWorkbook.Sheets("KS13")
.AutoFilterMode = False
With .Cells(1, 2)
.Resize(1, UBound(arr3, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr3, 2)) = Split("成本中心组;成本中心;部门编码;名称;描述;负责人;部门;利润中心;公司代码;数据线;打印机所在地;货币;CostCtrCat;功能范围;有效期自;有效期至;计划: 次成本(锁标识);计划: 收入(锁标识);计划: 主成本(锁标识);实际: 收入 (锁标识);实际: 主成本(锁标识);实际:次收入 (锁标识);成本核算表", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr3, 2)) = arr3
End With
End With
MsgBox "完成！"
End SubKSH1
KSH1建立成本中心组
Sub KSH1_创建成本中心组()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否创建成本中心组？" & Chr(10) & " " & Chr(10) & "创建之前要自行检查下是否确实需要创建！", vbYesNo, "KSH1")
If iMg = 7 Then Exit Sub
Dim x As Integer, y As Integer, rg As Range, sr As String, sg As String, v, u, i As Integer, j As Integer, k As Integer
sr = "KSH1"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
Dim arr()
arr = rg.CurrentRegion.Value
Dim dZ As Object
Set dZ = CreateObject("scripting.dictionary")
For x = 1 To UBound(arr, 2)
dZ(arr(1, x)) = x
Next x
Dim a As Byte, b As Byte, c As Byte, d As Byte
a = dZ("成本中心组")
b = dZ("成本中心组名称")
c = dZ("成本中心")
d = dZ("成本中心名称")
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For x = 2 To UBound(arr)
sr = arr(x, a)
sg = arr(x, c)
If Not dic1.exists(sr) Then
Set dic1(sr) = CreateObject("scripting.dictionary")
End If
dic1(sr)(sg) = ""
Next x
For x = 2 To UBound(arr)
sr = arr(x, a)
sg = arr(x, b)
dic2(sr) = sg
Next x
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
With session
For Each v In dic1.keys
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSH1"
.findById("wnd[0]").sendVKey 0 'Enter
If Not .findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]", False) Is Nothing Then '检测是否需要输入控制范围
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]").Text = 2688
.findById("wnd[0]").sendVKey 0
End If
.findById("wnd[0]/usr/ctxtGRPDYNP-NAME_COALL").Text = v
.findById("wnd[0]").sendVKey 0
If Not .findById("wnd[1]/usr/btnBUTTON_2", False) Is Nothing Then '检测是否被创建
.findById("wnd[1]/usr/btnBUTTON_2").press
MsgBox "失败！【" & v & "】已经被创建！"
Exit Sub
End If
.findById("wnd[0]/usr/txt[16,0]").Text = dic2(CStr(v))
i = 1 '记录屏幕上的输入框行数，跨页要重置
j = 0 '计算点击“插入成本中心”的次数
k = 0 '计算“竖向滚动条”下拉的频次
Do
j = j + 1
.findById("wnd[0]/tbar[1]/btn[16]").press
Loop Until j = dic1(CStr(v)).Count \ 5 + 1 '点击“插入成本中心”一次可以填五个成本中心
For Each u In dic1(CStr(v)).keys
i = i + 1
.findById("wnd[0]/usr/txt[4," & i & "]").Text = u
If i Mod 29 = 0 Then '测试DELL电脑最大显示的成本中心个数，到46时 i 会报错，要填45；测试华硕电脑是要写29
k = k + 1
.findById("wnd[0]/usr").verticalScrollbar.Position = i * k
i = 0
End If
Next u
.findById("wnd[0]/tbar[0]/btn[11]").press '保存（慎用）
Next v
End With
MsgBox "成功！"
End SubKSH2
KSH2修改成本中心组
Sub KSH2_标题()
Dim arr() As String
arr = Split("成本中心组;成本中心组名称;成本中心;成本中心名称", ";")
With ThisWorkbook.Sheets("KSH2")
.AutoFilterMode = False
.Cells(1, 1).Resize(1, UBound(arr) + 1) = arr
End With
End Sub
Sub KSH2_修改成本中心组_重置() '会修改成本中心组名称
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否修改成本中心组？" & Chr(10) & " " & Chr(10) & "修改之前要检查成本中心组是否已经创建，否则会出现修改一半进行不下去的情况！", vbYesNo, "KSH2")
If iMg = 7 Then Exit Sub
Dim x As Integer, y As Integer, rg As Range, sr As String, sg As String, v, u, i As Integer, j As Integer, k As Integer
sr = "KSH2"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
Dim arr()
arr = rg.CurrentRegion.Value
Dim dZ As Object
Set dZ = CreateObject("scripting.dictionary")
For x = 1 To UBound(arr, 2)
dZ(arr(1, x)) = x
Next x
Dim a As Byte, b As Byte, c As Byte, d As Byte
a = dZ("成本中心组")
b = dZ("成本中心组名称")
c = dZ("成本中心")
d = dZ("成本中心名称")
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For x = 2 To UBound(arr)
sr = arr(x, a)
sg = arr(x, c)
If Not dic1.exists(sr) Then
Set dic1(sr) = CreateObject("scripting.dictionary")
End If
dic1(sr)(sg) = ""
Next x
For x = 2 To UBound(arr)
sr = arr(x, a)
sg = arr(x, b)
dic2(sr) = sg
Next x
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
With session
For Each v In dic1.keys
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSH2"
.findById("wnd[0]").sendVKey 0 'Enter
If Not .findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]", False) Is Nothing Then '检测是否需要输入控制范围
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]").Text = 2688
.findById("wnd[0]").sendVKey 0
End If
.findById("wnd[0]/usr/ctxtGRPDYNP-NAME_COALL").Text = v
.findById("wnd[0]").sendVKey 0
If Not .findById("wnd[1]/usr/btnBUTTON_2", False) Is Nothing Then '检测是否有成本中心组
.findById("wnd[1]/usr/btnBUTTON_2").press
MsgBox "失败！【" & v & "】还没创建！"
Exit Sub
End If
.findById("wnd[0]/usr/txt[16,0]").Text = dic2(CStr(v))
Do '删除组下面所有的成本中心
If .findById("wnd[0]/usr/lbl[4,2]", False) Is Nothing Then Exit Do
.findById("wnd[0]/usr/lbl[4,2]").SetFocus
.findById("wnd[0]/tbar[1]/btn[9]").press
.findById("wnd[0]/tbar[1]/btn[5]").press
Loop
i = 1 '记录屏幕上的输入框行数，跨页要重置
j = 0 '计算点击“插入成本中心”的次数
k = 0 '计算“竖向滚动条”下拉的频次
Do
j = j + 1
.findById("wnd[0]/tbar[1]/btn[16]").press
Loop Until j = dic1(CStr(v)).Count \ 5 + 1 '点击“插入成本中心”一次可以填五个成本中心
For Each u In dic1(CStr(v)).keys
i = i + 1
.findById("wnd[0]/usr/txt[4," & i & "]").Text = u
If i Mod 29 = 0 Then '测试DELL电脑最大显示的成本中心个数，到46时 i 会报错，要填45；测试华硕电脑是要写29
k = k + 1
.findById("wnd[0]/usr").verticalScrollbar.Position = i * k
i = 0
End If
Next u
.findById("wnd[0]/tbar[0]/btn[11]").press '保存（慎用）
Next v
End With
MsgBox "成功！"
End Sub
Sub KSH2_修改成本中心组_新增() '不会改成本中心组名称
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否修改成本中心组？" & Chr(10) & " " & Chr(10) & "修改之前要检查成本中心组是否已经创建，否则会出现修改一半进行不下去的情况！", vbYesNo, "KSH2")
If iMg = 7 Then Exit Sub
Dim x As Integer, y As Integer, rg As Range, sr As String, sg As String, v, u, i As Integer, j As Integer, k As Integer
sr = "KSH2"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
Dim arr()
arr = rg.CurrentRegion.Value
Dim dZ As Object
Set dZ = CreateObject("scripting.dictionary")
For x = 1 To UBound(arr, 2)
dZ(arr(1, x)) = x
Next x
Dim a As Byte, b As Byte, c As Byte, d As Byte
a = dZ("成本中心组")
b = dZ("成本中心组名称")
c = dZ("成本中心")
d = dZ("成本中心名称")
Dim dic1 As Object
Set dic1 = CreateObject("scripting.dictionary")
For x = 2 To UBound(arr)
sr = arr(x, a)
sg = arr(x, c)
If Not dic1.exists(sr) Then
Set dic1(sr) = CreateObject("scripting.dictionary")
End If
dic1(sr)(sg) = ""
Next x
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
With session
For Each v In dic1.keys
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSH2"
.findById("wnd[0]").sendVKey 0 'Enter
If Not .findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]", False) Is Nothing Then '检测是否需要输入控制范围
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]").Text = 2688
.findById("wnd[0]").sendVKey 0
End If
.findById("wnd[0]/usr/ctxtGRPDYNP-NAME_COALL").Text = v
.findById("wnd[0]").sendVKey 0
If Not .findById("wnd[1]/usr/btnBUTTON_2", False) Is Nothing Then '检测是否有成本中心组
.findById("wnd[1]/usr/btnBUTTON_2").press
MsgBox "失败！【" & v & "】还没创建！"
Exit Sub
End If
i = 1 '记录屏幕上的输入框行数，跨页要重置
j = 0 '计算点击“插入成本中心”的次数
k = 0 '计算“竖向滚动条”下拉的频次
Do
j = j + 1
.findById("wnd[0]/tbar[1]/btn[16]").press
Loop Until j = dic1(CStr(v)).Count \ 5 + 1 '点击“插入成本中心”一次可以填五个成本中心
For Each u In dic1(CStr(v)).keys
i = i + 1
.findById("wnd[0]/usr/txt[4," & i & "]").Text = u
If i Mod 29 = 0 Then '测试DELL电脑最大显示的成本中心个数，到46时 i 会报错，要填45；测试华硕电脑是要写29
k = k + 1
.findById("wnd[0]/usr").verticalScrollbar.Position = i * k
i = 0
End If
Next u
.findById("wnd[0]/tbar[0]/btn[11]").press '保存（慎用）
Next v
End With
MsgBox "成功！"
End Sub
Sub KSH2_修改成本中心组_删除() '不会改成本中心组名称
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否修改成本中心组？" & Chr(10) & " " & Chr(10) & "修改之前要检查成本中心组是否已经创建，否则会出现修改一半进行不下去的情况！", vbYesNo, "KSH2")
If iMg = 7 Then Exit Sub
Dim x As Integer, y As Integer, rg As Range, sr As String, sg As String, v, u, i As Integer, j As Integer, k As Integer
sr = "KSH2"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
Dim arr()
arr = rg.CurrentRegion.Value
Dim dZ As Object
Set dZ = CreateObject("scripting.dictionary")
For x = 1 To UBound(arr, 2)
dZ(arr(1, x)) = x
Next x
Dim a As Byte, b As Byte, c As Byte, d As Byte
a = dZ("成本中心组")
b = dZ("成本中心组名称")
c = dZ("成本中心")
d = dZ("成本中心名称")
Dim dic1 As Object
Set dic1 = CreateObject("scripting.dictionary")
For x = 2 To UBound(arr)
sr = arr(x, a)
sg = arr(x, c)
If Not dic1.exists(sr) Then
Set dic1(sr) = CreateObject("scripting.dictionary")
End If
dic1(sr)(sg) = ""
Next x
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
With session
For Each v In dic1.keys
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSH2"
.findById("wnd[0]").sendVKey 0 'Enter
If Not .findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]", False) Is Nothing Then '检测是否需要输入控制范围
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]").Text = 2688
.findById("wnd[0]").sendVKey 0
End If
.findById("wnd[0]/usr/ctxtGRPDYNP-NAME_COALL").Text = v
.findById("wnd[0]").sendVKey 0
If Not .findById("wnd[1]/usr/btnBUTTON_2", False) Is Nothing Then '检测是否有成本中心组
.findById("wnd[1]/usr/btnBUTTON_2").press
MsgBox "失败！【" & v & "】还没创建！"
Exit Sub
End If
i = 1 '记录屏幕上的输入框行数，跨页要重置
j = 0 '计算点击“插入成本中心”的次数
Do
i = i + 1
If .findById("wnd[0]/usr/lbl[4," & i & "]", False) Is Nothing Then Exit Do '没有查到的就退出
If .findById("wnd[0]/usr/lbl[15," & i & "]", False) Is Nothing Then Exit Do '没有查到的就退出
sr = .findById("wnd[0]/usr/lbl[4," & i & "]").Text
If dic1(CStr(v)).exists(sr) Then
.findById("wnd[0]/usr/lbl[4," & i & "]").SetFocus
.findById("wnd[0]/tbar[1]/btn[9]").press
.findById("wnd[0]/tbar[1]/btn[5]").press
i = i - 1
End If
If i Mod 29 = 0 Then '测试DELL电脑最大显示的成本中心个数，到46时 i 会报错，要填45；测试华硕电脑是要写29
j = j + 1
.findById("wnd[0]/usr").verticalScrollbar.Position = i * j
i = 0
End If
Loop
.findById("wnd[0]/tbar[0]/btn[11]").press '保存（慎用）
Next v
End With
MsgBox "成功！"
End Sub
KSH3
KSH3显示成本中心组
Sub KSH3_显示成本中心组()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示成本中心组？" & Chr(10) & " " & Chr(10), vbYesNo, "KSH3")
If iMg = 7 Then Exit Sub
Dim x As Integer, sr As String, rg As Range, arr1(), arr2(), brr(), k As Integer, i As Integer, j As Integer, bl As Boolean
ReDim arr2(1 To 100000, 1 To 5)
ReDim brr(1 To 2)
sr = "KSH3"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
bl = False
With session
For x = 2 To UBound(arr1)
If arr1(x, 1) <> "" Then
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSH3" '显示成本中心组
.findById("wnd[0]").sendVKey 0 'Enter
If Not .findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]", False) Is Nothing Then '检测是否需要输入控制范围
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/ctxtSVALD-VALUE[0,21]").Text = 2688
.findById("wnd[0]").sendVKey 0
End If
.findById("wnd[0]/usr/ctxtGRPDYNP-NAME_COALL").Text = arr1(x, 1) '查询成本中心组
.findById("wnd[0]").sendVKey 0 'Enter
If Not .findById("wnd[1]/usr/btnBUTTON_2", False) Is Nothing Then '检测是否有成本中心组
.findById("wnd[1]/usr/btnBUTTON_2").press
bl = True
Else
brr(1) = .findById("wnd[0]/usr/lbl[0,0]").Text '成本中心组名称
brr(2) = .findById("wnd[0]/usr/lbl[16,0]").Text '成本中心组描述
i = 1 '记录屏幕上的输入框行数，跨页要重置
j = 0 '计算点击“插入成本中心”的次数
Do
i = i + 1
If .findById("wnd[0]/usr/lbl[4," & i & "]", False) Is Nothing Then Exit Do '没有查到的就退出
If .findById("wnd[0]/usr/lbl[15," & i & "]", False) Is Nothing Then Exit Do '没有查到的就退出
k = k + 1
arr2(k, 1) = brr(1)
arr2(k, 2) = brr(2)
arr2(k, 3) = .findById("wnd[0]/usr/lbl[4," & i & "]").Text
arr2(k, 4) = .findById("wnd[0]/usr/lbl[15," & i & "]").Text
If i Mod 29 = 0 Then '测试DELL电脑最大显示的成本中心个数，到46时 i 会报错，要填45；测试华硕电脑是要写29
j = j + 1
.findById("wnd[0]/usr").verticalScrollbar.Position = i * j
i = 0
End If
Loop
End If
End If
Next x
For x = 1 To k
If IsNumeric(Right(arr2(x, 3), 1)) Then
arr2(x, 5) = False
Else
arr2(x, 5) = True
End If
Next x
End With
With ThisWorkbook.Sheets("KSH3")
.AutoFilterMode = False
With .Cells(1, 2)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = Split("成本中心组;成本中心组名称;成本中心;成本中心名称;虚拟否", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr2, 2)) = arr2
End With
End With
If bl Then
MsgBox "有成本中心组未查到！"
Else
MsgBox "成功！"
End If
End SubFS00
Sub FS00_整理()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("FS00获取科目！" & Chr(10) & " " & Chr(10), vbYesNo, "FSOO")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim Table As Object, GetNodeK As Object, arr(), i As Integer, x
'进入程式获取节点
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NFS00"
.findById("wnd[0]").sendVKey 0 'Enter
Set Table = .findById("wnd[0]/shellcont/shell/shellcont[1]/shell[1]")
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
End With
'打开所有节点
For x = GetNodeK.Count - 1 To 0 Step -1
Table.expandNode GetNodeK.Item(x)
Next x
'重新读取shell[1]
Set Table = session.findById("wnd[0]/shellcont/shell/shellcont[1]/shell[1]")
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
For x = 0 To GetNodeK.Count - 1
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = GetNodeK.Item(x) '节点
arr(i) = Table.getitemtext(arr(i), "&Hierarchy") '获得内容
Next x
'With ThisWorkbook.Sheets("FS00")
' .AutoFilterMode = False
' .UsedRange.ClearContents
' .Cells(1, 1).Resize(i) = Application.Transpose(arr)
'End With
Dim brr(), v, j As Integer, sr As String
ReDim brr(1 To i, 1 To 4)
For x = 1 To i
If InStr(1, arr(x), " ") = 0 Then
sr = arr(x)
Else
j = j + 1
brr(j, 1) = sr
brr(j, 2) = arr(x)
brr(j, 3) = Split(arr(x), " ")(0)
brr(j, 4) = Trim(Replace(arr(x), brr(j, 3), ""))
End If
Next x
With ThisWorkbook.Sheets("FS00")
.AutoFilterMode = False
.UsedRange.ClearContents
.Cells(1, 1).Resize(1, UBound(brr, 2)) = Split("科目组;科目与科目描述;科目;科目描述", ";")
If j > 0 Then .Cells(2, 1).Resize(j, UBound(brr, 2)) = brr
End With
End SubSM30
SM30中，ZTCO0011B用于配置进销存报表，此方法在正式区读取表后又可以再测试区导入进去。
Sub SM30_ZTCO0011B_显示()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示ZTCO0011B？" & Chr(10) & " " & Chr(10), vbYesNo, "SM30")
If iMg = 7 Then Exit Sub
Dim x As Integer, y As Integer, sr As String, rg As Range, arr(), k As Integer, i As Integer, j As Integer, bl As Boolean
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
With session
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B").verticalScrollbar.Position = 0
sr = .findById("wnd[0]/usr/txtVIM_POSITION_INFO").Text
j = CDbl(Split(sr, "/")(1))
ReDim arr(0 To j, 1 To 6)
i = -1
For x = 0 To j
i = i + 1
arr(x, 1) = .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-BIZCODE[0," & i & "]").Text
arr(x, 2) = .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-BWART[1," & i & "]").Text
arr(x, 3) = .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-BIZTEXT[2," & i & "]").Text
arr(x, 4) = .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/cmbZTCO0011B-BIZATTR[3," & i & "]").Text
arr(x, 5) = .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/cmbZTCO0011B-SHKZG[4," & i & "]").Text
arr(x, 6) = .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-SOBKZ[5," & i & "]").Text
If i Mod 19 = 0 Then
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B").verticalScrollbar.Position = x
i = 0
End If
Next x
End With
With ThisWorkbook.Sheets("SM30_ZTCO0011B")
.AutoFilterMode = False
.Cells.ClearContents
.Cells(1, 1).Resize(1, UBound(arr, 2)) = Split("业务分类代码;MvT;业务分类描述;业务属性;借贷;特殊库存", ";")
.Cells(2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub
Sub SM30_ZTCO0011B_导入()
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object, Position
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim d As Object, x As Integer, y As Integer, rg As Range, sr As String, v, u, i As Integer, j As Integer, k As Integer
Set d = CreateObject("scripting.dictionary")
sr = "SM30_ZTCO0011B"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
Dim arr()
arr = rg.CurrentRegion.Value
d.Add "出库", "2"
d.Add "入库", "1"
d.Add "借方", "S"
d.Add "贷方", "H"
With session
i = -1
For x = 2 To UBound(arr)
i = i + 1
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-BIZCODE[0," & i & "]").Text = arr(x, 1)
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-BWART[1," & i & "]").Text = arr(x, 2)
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-BIZTEXT[2," & i & "]").Text = arr(x, 3)
If arr(x, 4) <> "" Then .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/cmbZTCO0011B-BIZATTR[3," & i & "]").Key = d(arr(x, 4))
If arr(x, 5) <> "" Then .findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/cmbZTCO0011B-SHKZG[4," & i & "]").Key = d(arr(x, 5))
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B/txtZTCO0011B-SOBKZ[5," & i & "]").Text = arr(x, 6)
If i Mod 19 = 0 Then
.findById("wnd[0]/usr/tblSAPLZFG_ZTCO0011BTCTRL_ZTCO0011B").verticalScrollbar.Position = x - 2
i = 0
End If
Next x
End With
End SubTcode
可以新建一个收藏夹，然后获取该收藏夹的节点，维护要插入的事务码，事务码和收藏夹要进行逆序排序
| 节点 | 文件夹 | 事物码 | 事物文本 |
| F00289 | PS_1.3_项目预算增加删减流程 | CJ37 | 项目中的预算补充 |
| F00289 | PS_1.3_项目预算增加删减流程 | CJ38 | 项目中的预算返回 |
| F00289 | PS_1.3_项目预算增加删减流程 | CJ32 | 改变工程发放 |
| F00289 | PS_1.3_项目预算增加删减流程 | CJ33 | 显示项目发行 |
| F00289 | PS_1.3_项目预算增加删减流程 | CJ3A | 改变预算凭证 |
| F00289 | PS_1.3_项目预算增加删减流程 | CJ3B | 显示预算文档 |
| F00289 | PS_1.2_项目预算编列流程 | CJ30 | 改变工程项目源预算 |
| F00289 | PS_1.2_项目预算编列流程 | CJ31 | 显示工程项目源预算 |
| F00289 | PS_1.2_项目预算编列流程 | CJ32 | 改变工程发放 |
| F00289 | PS_1.2_项目预算编列流程 | CJ33 | 显示项目发行 |
| F00289 | PS_1.2_项目预算编列流程 | CJ3A | 改变预算凭证 |
| F00289 | PS_1.2_项目预算编列流程 | CJ3B | 显示预算文档 |
| F00289 | PS_1.1_WBS主数据维护流程 | CJ01 | 生成工作细分结构 |
| F00289 | PS_1.1_WBS主数据维护流程 | CJ02 | 更改工作细分结构 |
| F00289 | PS_1.1_WBS主数据维护流程 | CJ03 | 显示工作细分结构 |
| F00289 | PS_1.1_WBS主数据维护流程 | CJ20N | 项目构建器 |
Sub Tcode_获取节点()
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim Table As Object, GetNodeK As Object, arr(), i As Integer, x As Integer, sr As String
ReDim Title(1 To 10)
'进入程式获取节点
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/N"
.findById("wnd[0]").sendVKey 0 'Enter
sr = "wnd[0]/usr/btnSTARTBUTTON"
If Not session.findById(sr, False) Is Nothing Then
.findById(sr).press
End If
Set Table = .findById("wnd[0]/usr/cntlIMAGE_CONTAINER/shellcont/shell/shellcont[0]/shell")
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
End With
For x = 0 To GetNodeK.Count - 1
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = GetNodeK.Item(x) '节点
Next x
With ThisWorkbook.Sheets("获取节点")
.AutoFilterMode = False
.UsedRange.ClearContents
.Cells(1, 1).Resize(i) = Application.Transpose(arr)
End With
End Sub
Sub Tcode_插入事物码()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("插入事务码！" & Chr(10) & " " & Chr(10), vbYesNo, "SAP_快速插入事务码")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim d As Object, x As Integer, rg As Range, k As Integer, s1 As String, s2 As String, v1, v2, v3
Set d = CreateObject("scripting.dictionary")
Dim Table As Object
s1 = "插入事务码"
Set rg = ThisWorkbook.Sheets(s1).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & s1 & "】中无数据！"
Exit Sub
End If
Dim arr()
arr = rg.CurrentRegion.Value
For x = 2 To UBound(arr)
s1 = arr(x, 1) '节点
s2 = arr(x, 2) '文件夹名称
If Not d.exists(s1) Then
Set d(s1) = CreateObject("scripting.dictionary")
End If
If Not d(s1).exists(s2) Then
Set d(s1)(s2) = CreateObject("scripting.dictionary")
End If
d(s1)(s2)(arr(x, 3)) = "" 'arr(x, 3) 是事务码
Next x
With session
.findById("wnd[0]").maximize
Set Table = .findById("wnd[0]/usr/cntlIMAGE_CONTAINER/shellcont/shell/shellcont[0]/shell")
For Each v1 In d.keys
For Each v2 In d(v1).keys
Table.selectedNode = v1
Table.nodeContextMenu v1
Table.selectContextMenuItem "XXFOLD" '插入文件夹
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/txtSVALD-VALUE[0,21]").Text = v2
.findById("wnd[1]/tbar[0]/btn[0]").press
For Each v3 In d(v1)(v2).keys
.findById("wnd[0]").maximize
Table.nodeContextMenu NodeKeys(CStr(v1))
Table.selectContextMenuItem "XXADTC" '插入事务码
.findById("wnd[1]/usr/sub:SAPLSPO4:0300/txtSVALD-VALUE[0,21]").Text = v3
.findById("wnd[1]/tbar[0]/btn[0]").press
Next v3
Next v2
Next v1
End With
Set d = Nothing
MsgBox "结束！"
End Sub
Function NodeKeys(s1 As String) As String '例如 要把 F00289 改成 F00290
Dim i As Integer, s2 As String
i = Len(s1)
s2 = CDbl(Right(s1, i - 1)) + 1
NodeKeys = "F" & Application.Rept(0, i - Len(s2) - 1) & s2
End FunctionCKM3N
批量查询料号的成本价明细
| 年 | 月 | 工厂 | 料号 |
| 2023 | 4 | 0510 | G1CMX085065A-Y |
Sub CKM3N_显示物料价格_跨月_多料号()
On Error Resume Next
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否在正式区显示物料价格？" & Chr(10) & " " & Chr(10), vbYesNo, "CKM3N")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Long, y As Integer, z As Integer, sr As String, rg As Range, arr1(), bl As Boolean, db As Double, k As Long, v
Dim Table As Object, Columns As Object, GetNodeK As Object
ReDim arr2(1 To 100000, 1 To 29)
sr = "CKM3N跨月"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
bl = False
With session
For x = 2 To UBound(arr1)
If arr1(x, 1) = "" Then Exit For
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NCKM3N"
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtMLKEY-WERKS_ML_PRODUCTIVE").Text = arr1(x, 3) '查询工厂
.findById("wnd[0]/usr/ctxtMLKEY-MATNR").Text = arr1(x, 4) '查询物料
.findById("wnd[0]/usr/txtMLKEY-POPER").Text = arr1(x, 2) '月
.findById("wnd[0]/usr/txtMLKEY-BDATJ").Text = arr1(x, 1) '年
.findById("wnd[0]/tbar[1]/btn[13]").press '刷新
.findById("wnd[0]/usr/btn%#AUTOTEXT003").press '折叠选择字段 价格
For Each v In Split("10;32", ";") '10" '公司层面 '"32"'利润中心层面 ';32
.findById("wnd[0]/usr/cmbMLKEY-CURTP").Key = v '货币/评估
sr = "wnd[0]/usr/ssubSUB:SAPLCKM8H:0300/cntlCONTAINER/shellcont/shell/shellcont[1]/shell[1]"
If Not .findById(sr, False) Is Nothing Then
Set Table = .findById(sr)
Set Columns = Table.ColumnOrder()
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
For z = 0 To GetNodeK.Count - 1
k = k + 1
For y = 1 To 4
arr2(k, y) = arr1(x, y)
Next y
arr2(k, 5) = .findById("wnd[0]/usr/cmbMLKEY-CURTP").Text '货币/评估
arr2(k, 6) = .findById("wnd[0]/usr/ctxtCKMLCR-VPRSV").Text '价格控制
arr2(k, 7) = .findById("wnd[0]/usr/txtCKMLCR-STPRS").Text '标准价格
arr2(k, 8) = .findById("wnd[0]/usr/txtCKMLCR-PVPRS").Text '定期价格 '正式区是 wnd[0]/usr/txtCKMLCR-PVPRS '测试区是 wnd[0]/usr/txtPVPRS_DYN
arr2(k, 9) = .findById("wnd[0]/usr/txtCKMLCR-PEINH").Text '价格单位
arr2(k, 12) = Table.getitemtext(GetNodeK.Item(z), "&Hierarchy")
For y = 1 To 17
arr2(k, y + 12) = Table.getitemtext(GetNodeK.Item(z), CStr(Columns(y)))
Next y
Next z
End If
Next v
Next x
End With
For x = 1 To k
db = arr2(x, 9) '价格单位
If db <> 0 Then
arr2(x, 10) = arr2(x, 7) / db '标准价=标准价格/价格单位
arr2(x, 11) = arr2(x, 8) / db '实际价=定期价格/价格单位
End If
arr2(x, 13) = CDbl(arr2(x, 13)) '数量
For y = 15 To 29
arr2(x, y) = CDbl(arr2(x, y)) '初级评估等
Next y
arr2(x, 3) = "'" & arr2(x, 3) '工厂
Next x
With ThisWorkbook.Sheets("CKM3N跨月")
.AutoFilterMode = False
With .Cells(1, 5)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = Split("年;月;工厂;物料;货币评估;价格控制;标准价格;定期价格;价格单位;标准价;实际价;类别;数量;数量单位;初级评估;价格差异;汇率差异;实际值;价格;公司间利润;直接材料;直接人工;间接人员薪资及福利;模具及治工具;资产摊提及能源消耗;耗品及杂项消耗;其他费用;委外加工;成本构成总和", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr2, 2)) = arr2
End With
End With
End SubCKM3N自行输入料号查询，只能开一个屏，否则会报错，可以自己打开节点，看想要的内容
Sub CKM3N_显示物料价格_明细_单月单笔()
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, y As Integer, z As Integer, sr As String, rg As Range, arr1(), k As Integer, brr(), bl As Boolean
Dim Table As Object, Columns As Object, GetNodeK As Object
ReDim arr2(1 To 100000, 1 To 18) '此处要提前知道列数，并且加了一列 'Table.ColumnCount()
With session
Set Table = .findById("wnd[0]/usr/ssubSUB:SAPLCKM8H:0300/cntlCONTAINER/shellcont/shell/shellcont[1]/shell[1]")
Set Columns = Table.ColumnOrder()
Set GetNodeK = Table.GetAllNodeKeys '得到所有的节点
For x = 0 To GetNodeK.Count - 1
k = k + 1
arr2(k, 1) = Table.getitemtext(GetNodeK.Item(x), "&Hierarchy")
For y = 1 To 17 'Table.ColumnCount() - 1
arr2(k, y + 1) = Table.getitemtext(GetNodeK.Item(x), CStr(Columns(y)))
Next y
Next x
For x = 1 To k
For y = 2 To UBound(arr2, 2)
If y <> 3 Then
If arr2(x, y) = "" Then
arr2(x, y) = 0
Else
arr2(x, y) = CDbl(arr2(x, y))
End If
End If
Next y
Next x
End With
With ThisWorkbook.Sheets("CKM3N明细")
.AutoFilterMode = False
.UsedRange.ClearContents
.Cells(1, 1).Resize(1, UBound(arr2, 2)) = Split("类别;数量;数量单位;初级评估;价格差异;汇率差异;实际值;价格;公司间利润;直接材料;直接人工;间接人员薪资及福利;模具及治工具;资产摊提及能源消耗;耗品及杂项消耗;其他费用;委外加工;成本构成总和", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr2, 2)) = arr2
End With
End SubFB02
FB02批量修改凭证文本的摘要
Sub FB02_修改凭证文本栏位()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否修改凭证文本栏位？" & Chr(10) & " " & Chr(10), vbYesNo, "FB02")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim Table As Object, Columns As Object
Dim arr1(), x As Integer, y As Integer, z As Integer, sr As String, rg As Range
sr = "FB02"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
For z = 2 To UBound(arr1)
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NFB02" '修改凭证
.findById("wnd[0]").sendVKey 0
.findById("wnd[0]/usr/txtRF05L-BELNR").Text = arr1(z, 3) '凭证编号
.findById("wnd[0]/usr/ctxtRF05L-BUKRS").Text = arr1(z, 2) '公司代码
.findById("wnd[0]/usr/txtRF05L-GJAHR").Text = arr1(z, 1) '会计年度
.findById("wnd[0]").sendVKey 0
'.findById("wnd[0]/usr/cntlCTRL_CONTAINERBSEG/shellcont/shell").selectColumn "SGTXT" '选中“文本”栏位
'.findById("wnd[0]/usr/cntlCTRL_CONTAINERBSEG/shellcont/shell").pressToolbarButton "&SORT_DSC" '排序
'.findById("wnd[0]/tbar[1]/btn[25]").press '更改模式
Set Table = .findById("wnd[0]/usr/cntlCTRL_CONTAINERBSEG/shellcont/shell")
Set Columns = Table.ColumnOrder()
For x = 0 To Table.RowCount() - 1
If Table.getcellvalue(x, "SGTXT") = arr1(z, 4) Then '原文本
Table.SetCurrentCell x, "KTONR"
Table.doubleClickCurrentCell '双击
.findById("wnd[0]/usr/ctxtBSEG-SGTXT").Text = arr1(z, 5) '更改后文本
.findById("wnd[0]/tbar[0]/btn[3]").press '返回
End If
If x Mod 14 = 0 Then '屏幕上显示的最大行数，根据电脑的不同可能有变
Table.SetCurrentCell x, CStr(Columns(0))
Table.firstVisibleRow = x
End If
Next x
.findById("wnd[0]/tbar[0]/btn[11]").press '保存
Next z
End With
End SubKSU1
可以创建分摊规则，这里主要还是用成本中心分摊，其他栏位情况没考虑
Sub KSU1_标题()
Dim arr() As String
arr = Split("循环名;循环名描述;开始时间;结束时间;段名;段名描述;发送者成本中心从;发送者成本中心至;发送者成本中心组;接收方成本中心从;接收方成本中心至;接收方成本中心组", ";")
With ThisWorkbook.Sheets("KSU1")
.AutoFilterMode = False
.Cells(1, 1).Resize(1, UBound(arr) + 1) = arr
End With
End Sub
Sub KSU1_创建实际分摊()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否创建实际分摊？" & Chr(10) & " " & Chr(10), vbYesNo, "KSU1")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, sr As String, rg As Range, arr1()
sr = "KSU1"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSU1" '创建实际分摊
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRKAL1-KSCYC").Text = arr1(2, 1) '循环名
.findById("wnd[0]/usr/ctxtT811C-SDATE").Text = arr1(2, 3) '开始时间
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtT811C-EDATE").Text = arr1(2, 4) '结束时间
.findById("wnd[0]/usr/txtRKAL1-CTXT").Text = arr1(2, 2) '循环名描述
For x = 2 To UBound(arr1)
.findById("wnd[0]/tbar[1]/btn[20]").press '增加段
.findById("wnd[0]/usr/txtKGALS-NAME").Text = arr1(x, 5) '段名
.findById("wnd[0]/usr/txtKGALS-TXT").Text = arr1(x, 6) '段名描述
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0307/ctxtKGALS-ABSCH").Text = "Z3" '分配结构
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0307/cmbRKAL1-RCDATAFLG").Key = "7" '可变部分类型
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS").Select '发送方/接收方
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[4,67]").Text = "ZZ00" '成本要素组 '修改
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[1,17]").Text = arr1(x, 7) '发送者成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[1,42]").Text = arr1(x, 8) '发送者成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[1,67]").Text = arr1(x, 9) '发送者成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[7,17]").Text = arr1(x, 10) '接收方成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[7,42]").Text = arr1(x, 11) '接收方成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[7,67]").Text = arr1(x, 12) '接收方成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND").Select '发送方值
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND/ssubSUB1:SAPMKAL1:0451/sub:SAPMKAL1:0451/ctxtKGALK-VALMIN[0,17]").Text = "0" '版本
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE").Select '接收方追踪因素
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMIN[0,17]").Text = "ZZ01" '活动类型：从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMAX[0,42]").Text = "ZZ06" '活动类型：到
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRWFC").Select '参考加权因素
Next x
End With
MsgBox "运行成功！"
End SubKSU2
修改已经创建的分摊规则
Sub KSU2_标题()
Dim arr() As String
arr = Split("查询循环名;查询开始时间;修改结束时间;修改循环名描述;修改段名;修改段名描述;修改发送者成本中心从;修改发送者成本中心至;修改发送者成本中心组;修改接收方成本中心从;修改接收方成本中心至;修改接收方成本中心组", ";")
With ThisWorkbook.Sheets("KSU2")
.AutoFilterMode = False
.Cells(1, 1).Resize(1, UBound(arr) + 1) = arr
End With
End Sub
Sub KSU2_修改实际分摊()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否修改实际分摊？" & Chr(10) & " " & Chr(10), vbYesNo, "KSU2")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, sr As String, rg As Range, arr1(), arr2(), brr(), k As Long, iMax As Integer, i As Integer, j As Integer
ReDim arr2(1 To 100000, 1 To 18)
ReDim brr(1 To 3)
sr = "KSU2"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSU2" '修改实际分配
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRKAL1-KSCYC").Text = arr1(2, 1) '循环名
.findById("wnd[0]/usr/ctxtT811C-SDATE").Text = arr1(2, 2) '开始日期
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtT811C-EDATE").Text = arr1(2, 3) '结束时间
.findById("wnd[0]/usr/txtRKAL1-CTXT").Text = arr1(2, 4) '循环名描述
.findById("wnd[0]/tbar[1]/btn[6]").press '第一个段
.findById("wnd[0]/mbar/menu[2]/menu[1]").Select '转到>>概述段
j = .findById("wnd[1]/usr/txtRCEVM-ENTRIES").Text '段号
.findById("wnd[1]/tbar[0]/btn[12]").press '取消段概览
For x = 1 To j '为了修改的时候不重名
.findById("wnd[0]/usr/txtKGALS-NAME").Text = x
If x <> j Then .findById("wnd[0]/tbar[1]/btn[19]").press '下一段
Next x
For x = 1 To j - 1 '回退到第一个段
.findById("wnd[0]/tbar[1]/btn[18]").press '前一段
Next x
For x = 2 To UBound(arr1)
i = i + 1
.findById("wnd[0]/usr/txtKGALS-NAME").Text = arr1(x, 5) '段名 （不能大于十个字符）
.findById("wnd[0]/usr/txtKGALS-TXT").Text = arr1(x, 6) '段名描述
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0307/ctxtKGALS-ABSCH").Text = "Z3" '分配结构
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0307/cmbRKAL1-RCDATAFLG").Key = "7" '可变部分类型
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS").Select '发送方/接收方
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[4,67]").Text = "ZZ00" '成本要素组
.findById("wnd[0]/usr/chkKGALS-ACTIVE").Selected = False '锁定标识符
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[1,17]").Text = arr1(x, 7) '发送者成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[1,42]").Text = arr1(x, 8) '发送者成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[1,67]").Text = arr1(x, 9) '发送者成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[7,17]").Text = arr1(x, 10) '接收方成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[7,42]").Text = arr1(x, 11) '接收方成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[7,67]").Text = arr1(x, 12) '接收方成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND").Select '发送方值
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND/ssubSUB1:SAPMKAL1:0451/sub:SAPMKAL1:0451/ctxtKGALK-VALMIN[0,17]").Text = "0" '版本
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE").Select '接收方追踪因素
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMIN[0,17]").Text = "ZZ01" '活动类型：从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMAX[0,42]").Text = "ZZ06" '活动类型：到
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRWFC").Select '参考加权因素
If x = UBound(arr1) Then
ElseIf i < j Then
.findById("wnd[0]/tbar[1]/btn[19]").press
Else
.findById("wnd[0]/tbar[1]/btn[20]").press '增加段
End If
Next x
Do While i < j '如果没有修改的必要则全部锁定掉
i = i + 1
.findById("wnd[0]/tbar[1]/btn[19]").press '下一个段
.findById("wnd[0]/usr/chkKGALS-ACTIVE").Selected = "TRUE" '锁定标识符
Loop
End With
MsgBox "请自行保存！"
End SubKSU3
显示分摊规则
| 查询循环名 | 查询开始时间 |
| C12101 | 2022.06.01 |
Sub KSU3_标题()
Dim arr() As String
arr = Split("查询循环名;查询开始时间;循环名;循环名描述;开始时间;结束时间;段名;段名描述;锁定标识符;分配结构;可变部分类型;成本要素组;发送者成本中心从;发送者成本中心至;发送者成本中心组;接收方成本中心从;接收方成本中心至;接收方成本中心组;版本;活动类型从;活动类型到", ";")
With ThisWorkbook.Sheets("KSU3")
.AutoFilterMode = False
.Cells(1, 1).Resize(1, UBound(arr) + 1) = arr
End With
End Sub
Sub KSU3_显示实际分摊()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示实际分摊？" & Chr(10) & " " & Chr(10), vbYesNo, "KSU3")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, sr As String, rg As Range, arr1(), arr2(), brr(), k As Long, iMax As Integer, i As Integer, j As Integer
ReDim arr2(1 To 100000, 1 To 19)
ReDim brr(1 To 3)
sr = "KSU3"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
For x = 2 To UBound(arr1)
If arr1(x, 1) <> "" Then
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSU3" '显示实际分摊
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRKAL1-KSCYC").Text = arr1(x, 1) '循环名
.findById("wnd[0]/usr/ctxtT811C-SDATE").Text = arr1(x, 2) '开始日期
.findById("wnd[0]").sendVKey 0 'Enter
brr(1) = .findById("wnd[0]/usr/txtRKAL1-CTXT").Text '循环名描述
brr(2) = .findById("wnd[0]/usr/ctxtT811C-SDATE").Text '开始时间
brr(3) = .findById("wnd[0]/usr/ctxtT811C-EDATE").Text '结束时间
.findById("wnd[0]/tbar[1]/btn[6]").press '第一个段
.findById("wnd[0]/mbar/menu[2]/menu[1]").Select '转到>>概述段
j = .findById("wnd[1]/usr/txtRCEVM-ENTRIES").Text '段号
.findById("wnd[1]/tbar[0]/btn[12]").press '取消段概览
i = 0
Do
On Error Resume Next
k = k + 1
i = i + 1
arr2(k, 1) = arr1(x, 1)
arr2(k, 2) = brr(1)
arr2(k, 3) = brr(2)
arr2(k, 4) = brr(3)
arr2(k, 5) = .findById("wnd[0]/usr/txtKGALS-NAME").Text '段名
arr2(k, 6) = .findById("wnd[0]/usr/txtKGALS-TXT").Text '段名描述
arr2(k, 7) = .findById("wnd[0]/usr/chkKGALS-ACTIVE").Selected '锁定标识符
arr2(k, 8) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0307/ctxtKGALS-ABSCH").Text '分配结构
arr2(k, 9) = Trim(.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0307/cmbRKAL1-RCDATAFLG").Text) '可变部分类型
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS").Select '发送方/接收方
arr2(k, 10) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[4,67]").Text '成本要素组
arr2(k, 11) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[1,17]").Text '发送者成本中心从
arr2(k, 12) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[1,42]").Text '发送者成本中心至
arr2(k, 13) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[1,67]").Text '发送者成本中心组
arr2(k, 14) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[7,17]").Text '接收方成本中心从
arr2(k, 15) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[7,42]").Text '接收方成本中心至
arr2(k, 16) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[7,67]").Text '接收方成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND").Select '发送方值
arr2(k, 17) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND/ssubSUB1:SAPMKAL1:0451/sub:SAPMKAL1:0451/ctxtKGALK-VALMIN[0,17]").Text '版本
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE").Select '接收方追踪因素
arr2(k, 18) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMIN[0,17]").Text '活动类型：从
arr2(k, 19) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMAX[0,42]").Text '活动类型：到
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRWFC").Select '参考加权因素
.findById("wnd[0]/tbar[1]/btn[19]").press
Loop Until i >= j
.findById("wnd[1]/tbar[0]/btn[0]").press
End If
Next x
End With
With ThisWorkbook.Sheets("KSU3")
.AutoFilterMode = False
With .Cells(1, 3)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = Split("循环名;循环名描述;开始时间;结束时间;段名;段名描述;锁定标识符;分配结构;可变部分类型;成本要素组;发送者成本中心从;发送者成本中心至;发送者成本中心组;接收方成本中心从;接收方成本中心至;接收方成本中心组;版本;活动类型从;活动类型到", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr2, 2)) = arr2
End With
End With
MsgBox "成功"
End Sub
KSV1、KSV2、KSV3
分配
Sub KSV1_创建实际分配()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否创建实际分配？" & Chr(10) & " " & Chr(10), vbYesNo, "KSV1")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, sr As String, rg As Range, arr1()
sr = "KSV1"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSV1" '创建实际分摊
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRKAL1-KSCYC").Text = arr1(2, 1) '循环名
.findById("wnd[0]/usr/ctxtT811C-SDATE").Text = arr1(2, 3) '开始时间
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtT811C-EDATE").Text = arr1(2, 4) '结束时间
.findById("wnd[0]/usr/txtRKAL1-CTXT").Text = arr1(2, 2) '循环名描述
For x = 2 To UBound(arr1)
.findById("wnd[0]/tbar[1]/btn[20]").press '增加段
.findById("wnd[0]/usr/txtKGALS-NAME").Text = arr1(x, 5) '段名
.findById("wnd[0]/usr/txtKGALS-TXT").Text = arr1(x, 6) '段名描述
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0308/cmbRKAL1-RCDATAFLG").Key = "7" '可变部分类型
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS").Select '发送方/接收方
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[3,67]").Text = "ZZ00" '成本要素组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[1,17]").Text = arr1(x, 7) '发送者成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[1,42]").Text = arr1(x, 8) '发送者成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[1,67]").Text = arr1(x, 9) '发送者成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[7,17]").Text = arr1(x, 10) '接收方成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[7,42]").Text = arr1(x, 11) '接收方成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[7,67]").Text = arr1(x, 12) '接收方成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND").Select '发送方值
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND/ssubSUB1:SAPMKAL1:0451/sub:SAPMKAL1:0451/ctxtKGALK-VALMIN[0,17]").Text = "0" '版本
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE").Select '接收方追踪因素
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMIN[0,17]").Text = "ZZ01" '活动类型：从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMAX[0,42]").Text = "ZZ06" '活动类型：到
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRWFC").Select '参考加权因素
Next x
End With
MsgBox "运行成功！"
End Sub
Sub KSV3_显示实际分配()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否显示实际分配？" & Chr(10) & " " & Chr(10), vbYesNo, "KSV3")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, sr As String, rg As Range, arr1(), arr2(), brr(), k As Long, iMax As Integer, i As Integer, j As Integer
ReDim arr2(1 To 100000, 1 To 18)
ReDim brr(1 To 3)
sr = "KSV3"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
For x = 2 To UBound(arr1)
If arr1(x, 1) <> "" Then
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSV3" '显示实际分配
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRKAL1-KSCYC").Text = arr1(x, 1) '循环名
.findById("wnd[0]/usr/ctxtT811C-SDATE").Text = arr1(x, 2) '开始日期
.findById("wnd[0]").sendVKey 0 'Enter
brr(1) = .findById("wnd[0]/usr/txtRKAL1-CTXT").Text '循环名描述
brr(2) = .findById("wnd[0]/usr/ctxtT811C-SDATE").Text '开始时间
brr(3) = .findById("wnd[0]/usr/ctxtT811C-EDATE").Text '结束时间
.findById("wnd[0]/tbar[1]/btn[6]").press '第一个段
.findById("wnd[0]/mbar/menu[2]/menu[1]").Select '转到>>概述段
j = .findById("wnd[1]/usr/txtRCEVM-ENTRIES").Text '段号
.findById("wnd[1]/tbar[0]/btn[12]").press '取消段概览
i = 0
Do
On Error Resume Next
k = k + 1
i = i + 1
arr2(k, 1) = arr1(x, 1)
arr2(k, 2) = brr(1)
arr2(k, 3) = brr(2)
arr2(k, 4) = brr(3)
arr2(k, 5) = .findById("wnd[0]/usr/txtKGALS-NAME").Text '段名
arr2(k, 6) = .findById("wnd[0]/usr/txtKGALS-TXT").Text '段名描述
arr2(k, 7) = .findById("wnd[0]/usr/chkKGALS-ACTIVE").Selected '锁定标识符
arr2(k, 8) = Trim(.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0308/cmbRKAL1-RCDATAFLG").Text) '可变部分类型
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS").Select '发送方/接收方
arr2(k, 9) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[3,67]").Text '成本要素组
arr2(k, 10) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[1,17]").Text '发送者成本中心从
arr2(k, 11) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[1,42]").Text '发送者成本中心至
arr2(k, 12) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[1,67]").Text '发送者成本中心组
arr2(k, 13) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[7,17]").Text '接收方成本中心从
arr2(k, 14) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[7,42]").Text '接收方成本中心至
arr2(k, 15) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[7,67]").Text '接收方成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND").Select '发送方值
arr2(k, 16) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND/ssubSUB1:SAPMKAL1:0451/sub:SAPMKAL1:0451/ctxtKGALK-VALMIN[0,17]").Text '版本
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE").Select '接收方追踪因素
arr2(k, 17) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMIN[0,17]").Text '活动类型：从
arr2(k, 18) = .findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMAX[0,42]").Text '活动类型：到
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRWFC").Select '参考加权因素
.findById("wnd[0]/tbar[1]/btn[19]").press
Loop Until i >= j
.findById("wnd[1]/tbar[0]/btn[0]").press
End If
Next x
End With
With ThisWorkbook.Sheets("KSV3")
.AutoFilterMode = False
With .Cells(1, 3)
.Resize(1, UBound(arr2, 2)).EntireColumn.ClearContents
.Resize(1, UBound(arr2, 2)) = Split("循环名;循环名描述;开始时间;结束时间;段名;段名描述;锁定标识符;可变部分类型;成本要素组;发送者成本中心从;发送者成本中心至;发送者成本中心组;接收方成本中心从;接收方成本中心至;接收方成本中心组;版本;活动类型从;活动类型到", ";")
If k > 0 Then .Cells(2, 1).Resize(k, UBound(arr2, 2)) = arr2
End With
End With
MsgBox "成功"
End Sub
Sub KSV2_修改实际分配()
Dim iMg As VbMsgBoxStyle
iMg = MsgBox("是否修改实际分配？" & Chr(10) & " " & Chr(10), vbYesNo, "KSV2")
If iMg = 7 Then Exit Sub
Dim SapGuiAuto As Object, AppSap As Object, Connection As Object, session As Object
Set SapGuiAuto = GetObject("SAPGUI")
Set AppSap = SapGuiAuto.GetScriptingEngine
Set Connection = AppSap.Children(0)
Set session = Connection.Children(0)
Dim x As Integer, sr As String, rg As Range, arr1(), arr2(), brr(), k As Long, iMax As Integer, i As Integer, j As Integer
ReDim arr2(1 To 100000, 1 To 18)
ReDim brr(1 To 3)
sr = "KSV2"
Set rg = ThisWorkbook.Sheets(sr).UsedRange.Find("*")
If rg Is Nothing Then
MsgBox "错误！表【" & sr & "】中无数据！"
Exit Sub
End If
arr1 = rg.CurrentRegion.Value
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "/NKSV2" '修改实际分配
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtRKAL1-KSCYC").Text = arr1(2, 1) '循环名
.findById("wnd[0]/usr/ctxtT811C-SDATE").Text = arr1(2, 2) '开始日期
.findById("wnd[0]").sendVKey 0 'Enter
.findById("wnd[0]/usr/ctxtT811C-EDATE").Text = arr1(2, 3) '结束时间
.findById("wnd[0]/usr/txtRKAL1-CTXT").Text = arr1(2, 4) '循环名描述
.findById("wnd[0]/tbar[1]/btn[6]").press '第一个段
.findById("wnd[0]/mbar/menu[2]/menu[1]").Select '转到>>概述段
j = .findById("wnd[1]/usr/txtRCEVM-ENTRIES").Text '段号
.findById("wnd[1]/tbar[0]/btn[12]").press '取消段概览
For x = 1 To j '为了修改的时候不重名
.findById("wnd[0]/usr/txtKGALS-NAME").Text = x
If x <> j Then .findById("wnd[0]/tbar[1]/btn[19]").press '下一段
Next x
For x = 1 To j - 1 '回退到第一个段
.findById("wnd[0]/tbar[1]/btn[18]").press '前一段
Next x
For x = 2 To UBound(arr1)
i = i + 1
.findById("wnd[0]/usr/txtKGALS-NAME").Text = arr1(x, 5) '段名 （不能大于十个字符）
.findById("wnd[0]/usr/txtKGALS-TXT").Text = arr1(x, 6) '段名描述
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSQHD/ssubSUB1:SAPMKAL1:0308/cmbRKAL1-RCDATAFLG").Key = "7" '可变部分类型
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS").Select '发送方/接收方
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[3,67]").Text = "ZZ00" '成本要素组
.findById("wnd[0]/usr/chkKGALS-ACTIVE").Selected = arr1(x, 7) '锁定标识符
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[1,17]").Text = arr1(x, 8) '发送者成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[1,42]").Text = arr1(x, 9) '发送者成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[1,67]").Text = arr1(x, 10) '发送者成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMIN[7,17]").Text = arr1(x, 11) '接收方成本中心从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-VALMAX[7,42]").Text = arr1(x, 12) '接收方成本中心至
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpOBJS/ssubSUB1:SAPMKAL1:0306/sub:SAPMKAL1:0306/ctxtKGALK-SETID[7,67]").Text = arr1(x, 13) '接收方成本中心组
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND").Select '发送方值
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpSEND/ssubSUB1:SAPMKAL1:0451/sub:SAPMKAL1:0451/ctxtKGALK-VALMIN[0,17]").Text = "0" '版本
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE").Select '接收方追踪因素
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMIN[0,17]").Text = "ZZ01" '活动类型：从
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRECE/ssubSUB1:SAPMKAL1:0461/sub:SAPMKAL1:0461/ctxtKGALK-VALMAX[0,42]").Text = "ZZ06" '活动类型：到
.findById("wnd[0]/usr/tabsSEG_TABSTRIP/tabpRWFC").Select '参考加权因素
If x = UBound(arr1) Then
ElseIf i < j Then
.findById("wnd[0]/tbar[1]/btn[19]").press
Else
.findById("wnd[0]/tbar[1]/btn[20]").press '增加段
End If
Next x
Do While i < j '如果没有修改的必要则全部锁定掉
i = i + 1
.findById("wnd[0]/tbar[1]/btn[19]").press '下一个段
.findById("wnd[0]/usr/chkKGALS-ACTIVE").Selected = "TRUE" '锁定标识符
Loop
End With
MsgBox "成功"
End Sub
与其他方式对比
- RPA脚本运行时不能操作键盘鼠标，VBA运行时可以操作SAP的其他界面，操作键盘鼠标也没影响。
- RPA 比如勾选复选框后需要等待程式运行，VBA不用
- VBA是在简体版本的Excel运行，与繁体版的Excel不通用，中文会有乱码。
- RPA运用更广泛，可以在其他应用运行。
- 与Tricentis对比
2066
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
