To load a bill of materials into SAP I needed to create a XML file with the hierarchy of the bill. To start this project in Access you will need to set a reference to ChilkatXML (free from chilkatsoft.com), or you use MS DOM Object but I prefer the coding structure provided by chilkat, and a table for the BOM items. Starting with the top levels you can then create the required number of BOM levels. You will need to amend the nodes of the XML file to suit your BOM levels.
Sub Make_SAP_XML_v3()
'------------------------------------------------------
' 'Excel macro to Export a BOM for SAP Upload
'-----------------------------------------------------
Dim xml As New ChilkatXml
Dim BookingHeader As ChilkatXml
Dim ProductHeader As ChilkatXml
Dim Systems As ChilkatXml
Dim System As ChilkatXml
Dim tmpTest As Boolean, myFile, tmpStr, tmpFile, tmpPath, tmpRev, tmpCount
Dim tmpCabinet As String, tmpCurr As String
Dim tmpVal As String, tmpSystemID As String
Dim tmpName As String
Dim tmpCabType As String
Dim tmpProType As String
Dim I As Integer
Dim tmpSystem As String
Dim tmpTopLevel As Integer
Dim tmpATO As Integer
Dim tmpSystemLine As Integer
Dim tmpOrder
Dim tmpItemNo As Integer, tmpOrderLine As Integer, tmpItemNo2 As Integer
Dim tmptestPO As Boolean, tmpBOMDesc, tmpCost
Dim x As Variant
Dim ws As Worksheet
Set ws = Worksheets("Descriptions")
xml.Tag = "MT_Project_WBSBOM_CREATE"
xml.AddAttribute "xmlns:nr1", "http://xxxxxx.com/contract_to_order"
ActiveWorkbook.Worksheets("Header").Select
Range("f1").Select
If ActiveCell.Value > 0 Then
MsgBox "You are missing manditory information on the Header tab" & vbCrLf & "Please correct the data and retry"
Exit Sub
End If
Range("c2").Select
Set BookingHeader = xml.NewChild("BookingHeader", "")
BookingHeader.NewChild2 "SoldtoCompany", ActiveCell.Offset(1, 0).Value
BookingHeader.NewChild2 "SoldtoAddress1", ActiveCell.Offset(2, 0).Value
BookingHeader.NewChild2 "SoldtoAddress2", ActiveCell.Offset(3, 0).Value
BookingHeader.NewChild2 "SoldtoAddress3", ActiveCell.Offset(4, 0).Value
BookingHeader.NewChild2 "SoldtoAddress4", ActiveCell.Offset(5, 0).Value
BookingHeader.NewChild2 "SoldtoAttn", ActiveCell.Offset(6, 0).Value
BookingHeader.NewChild2 "HardwareShiptoCompany", ActiveCell.Offset(8, 0).Value
BookingHeader.NewChild2 "HardwareShiptoAddress1", ActiveCell.Offset(9, 0).Value
BookingHeader.NewChild2 "HardwareShiptoAddress2", ActiveCell.Offset(10, 0).Value
BookingHeader.NewChild2 "HardwareShiptoAddress3", ActiveCell.Offset(11, 0).Value
BookingHeader.NewChild2 "HardwareShiptoAddress4", ActiveCell.Offset(12, 0).Value
BookingHeader.NewChild2 "DeliveryContact", ActiveCell.Offset(14, 0).Value
BookingHeader.NewChild2 "DeliveryPhone", ActiveCell.Offset(15, 0).Value
BookingHeader.NewChild2 "SalesOrder", ActiveCell.Offset(17, 0).Value
BookingHeader.NewChild2 "OracleCIBSoldtoPartnerNumber", ActiveCell.Offset(19, 0).Value
BookingHeader.NewChild2 "OracleDefaultTaskCode", ActiveCell.Offset(20, 0).Value
BookingHeader.NewChild2 "OracleID", ActiveCell.Offset(21, 0).Value
BookingHeader.NewChild2 "PurchaseOrderNumber", ActiveCell.Offset(23, 0).Value
BookingHeader.NewChild2 "ProjectName", ActiveCell.Offset(24, 0).Value
BookingHeader.NewChild2 "OrderType", ActiveCell.Offset(26, 0).Value
BookingHeader.NewChild2 "EndUserCompany", ActiveCell.Offset(28, 0).Value
BookingHeader.NewChild2 "EndUserAddress1", ActiveCell.Offset(29, 0).Value
BookingHeader.NewChild2 "EndUserAddress2", ActiveCell.Offset(30, 0).Value
BookingHeader.NewChild2 "EndUserAddress3", ActiveCell.Offset(31, 0).Value
BookingHeader.NewChild2 "EndUserCity", ActiveCell.Offset(32, 0).Value
BookingHeader.NewChild2 "EndUserState", ActiveCell.Offset(33, 0).Value
BookingHeader.NewChild2 "EndUserCountry", ActiveCell.Offset(34, 0).Value
BookingHeader.NewChild2 "EndUserContactTelephone", ActiveCell.Offset(35, 0).Value
BookingHeader.NewChild2 "EndUserPostalCode", ActiveCell.Offset(36, 0).Value
BookingHeader.NewChild2 "RequestDate", ActiveCell.Offset(38, 0).Value
BookingHeader.NewChild2 "TradeTerms", ActiveCell.Offset(40, 0).Value
BookingHeader.NewChild2 "FreightForwarderName", ActiveCell.Offset(42, 0).Value
BookingHeader.NewChild2 "FreightForwarderAddress1", ActiveCell.Offset(43, 0).Value
BookingHeader.NewChild2 "FreightForwarderAddress2", ActiveCell.Offset(44, 0).Value
BookingHeader.NewChild2 "FreightForwarderCity", ActiveCell.Offset(45, 0).Value
BookingHeader.NewChild2 "FreightForwarderState", ActiveCell.Offset(46, 0).Value
BookingHeader.NewChild2 "FreightForwarderCountry", ActiveCell.Offset(47, 0).Value
BookingHeader.NewChild2 "FreightForwarderTelephone", ActiveCell.Offset(48, 0).Value
BookingHeader.NewChild2 "FreightForwarderPostalCode", ActiveCell.Offset(49, 0).Value
BookingHeader.NewChild2 "FreightTerms", ActiveCell.Offset(50, 0).Value
BookingHeader.NewChild2 "ShippingMarks1", ActiveCell.Offset(52, 0).Value
BookingHeader.NewChild2 "ShippingMarks2", ActiveCell.Offset(53, 0).Value
BookingHeader.NewChild2 "ShippingMarks3", ActiveCell.Offset(54, 0).Value
BookingHeader.NewChild2 "ShippingMarks4", ActiveCell.Offset(55, 0).Value
tmpCurr = ActiveCell.Offset(57, 0).Value
tmpBOMDesc = ActiveCell.Offset(59, 0).Value
'set the header values
Set ProductHeader = xml.NewChild("WBSBOMHeader", "")
ActiveWorkbook.Worksheets("Version").Select
Range("B1").Select
ProductHeader.NewChild2 "ConfigSource", ActiveCell.Value
ProductHeader.NewChild2 "TPCVersion", ActiveCell.Offset(1, 0).Value
ProductHeader.NewChild2 "TPCInternalDate", ActiveCell.Offset(2, 0).Value
ProductHeader.NewChild2 "TPCEngInfoDate", ActiveCell.Offset(3, 0).Value
ProductHeader.NewChild2 "TPCEngInfoFileVersion", ActiveCell.Offset(4, 0).Value
ProductHeader.NewChild2 "CommerciallyComplete", ActiveCell.Offset(5, 0).Value
ProductHeader.NewChild2 "WBSBOMCurrencyCode", tmpCurr
ProductHeader.NewChild2 "OpportunityID", "" 'rst!ID 'use the is of the passed recordset
ProductHeader.NewChild2 "QuoteID", ""
ProductHeader.NewChild2 "GlobalProjectID", ""
ActiveWorkbook.Worksheets("Factory_BOM").Select
Range("A1").Select
If Range("A1") <> "System" Then
MsgBox ("This is not the correct sheet")
Exit Sub
End If
ProductHeader.NewChild2 "SystemID", tmpBOMDesc
tmpSystemLine = 0
tmpSystem = ""
tmpOrderLine = 1
tmpItemNo = 1
tmpSystemLine = tmpSystemLine + 1
tmpItemNo = 0
tmpItemNo2 = 1
tmpTopLevel = 1
tmpATO = 0
tmpTest = True
tmpStr = ""
Application.ScreenUpdating = False
Range("A1").Select
If Range("A1") <> "System" Then
MsgBox ("This is not the correct sheet")
Exit Sub
End If
If Len(Range("C1") & "") < 4 Then
MsgBox ("Please Enter 'Rev X' in B1")
Exit Sub
End If
Range("A2").Select
tmpSystem = ActiveCell.Value
tmpCabinet = ""
Set Systems = ProductHeader.NewChild("WBSBOMItem", "")
'Make a new Parent
'_____________________________________
Systems.NewChild2 "WBSBOMParentName", ""
Systems.NewChild2 "WBSBOMProduct", tmpSystem
Systems.NewChild2 "WBSBOMLineNumber", tmpOrderLine
Systems.NewChild2 "WBSBOMQuantity", "1"
Systems.NewChild2 "WBSBOMRowID", tmpOrderLine 'tmpPro & "_" & tmpOrderLine 'TmpProType & "0" & tmpOrderLine & "_" & tmpOrderLine
Systems.NewChild2 "WBSBOMCustomerSupplied", ""
'lookup the cabinet description
On Error GoTo Skip
x = Application.WorksheetFunction.VLookup(tmpSystem, ws.Range("A5:B105"), 2, False)
Skip:
Systems.NewChild2 "WBSBOMDescription", IIf(x <> 0, x, "")
Systems.NewChild2 "WBSBOMImportSource", ""
Systems.NewChild2 "WBSBOMMilestoneBillFlag", ""
Systems.NewChild2 "WBSBOMParentItemNumber", "0"
Systems.NewChild2 "WBSBOMType", ""
Systems.NewChild2 "WBSBOMUnitCost", ""
Systems.NewChild2 "WBSBOMUnitOfMeasure", tmpCurr
Systems.NewChild2 "WBSBOMName", ""
Systems.NewChild2 "WBSBOMPackage", ""
Systems.NewChild2 "WBSBOMPkgDescription", ""
'________________________________________
tmpCount = 2
Do While tmpTest
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value <> "" Then
If tmpSystem <> ActiveCell.Offset(0, -1) Then
'-------------------------------------------------
tmpTopLevel = tmpTopLevel + 1
tmpATO = 0
tmpSystem = ActiveCell.Offset(0, -1)
Set Systems = ProductHeader.NewChild("WBSBOMItem", "")
Systems.NewChild2 "WBSBOMParentName", ""
Systems.NewChild2 "WBSBOMProduct", ActiveCell.Offset(0, -1)
Systems.NewChild2 "WBSBOMLineNumber", tmpTopLevel ' tmpOrderLine
Systems.NewChild2 "WBSBOMQuantity", "1"
Systems.NewChild2 "WBSBOMRowID", tmpTopLevel 'tmpSystemLine & "." & tmpItemNo 'tmpPro & "_" & tmpOrderLine 'TmpProType & "0" & tmpOrderLine & "_" & tmpOrderLine
Systems.NewChild2 "WBSBOMCustomerSupplied", ""
'lookup the cabinet description
On Error GoTo Skip1
x = Application.WorksheetFunction.VLookup(tmpSystem, ws.Range("A5:B105"), 2, False)
Skip1:
Systems.NewChild2 "WBSBOMDescription", IIf(x <> 0, x, "")
Systems.NewChild2 "WBSBOMImportSource", ""
Systems.NewChild2 "WBSBOMMilestoneBillFlag", ""
Systems.NewChild2 "WBSBOMParentItemNumber", "0"
Systems.NewChild2 "WBSBOMType", ""
Systems.NewChild2 "WBSBOMUnitCost", ""
Systems.NewChild2 "WBSBOMUnitOfMeasure", tmpCurr
Systems.NewChild2 "WBSBOMName", ""
Systems.NewChild2 "WBSBOMPackage", ""
Systems.NewChild2 "WBSBOMPkgDescription", ""
'-------------------------------------------------
End If
'are we starting a new system node?
If tmpCabinet <> ActiveCell.Value Then
tmpCabinet = ActiveCell.Value
tmpOrderLine = tmpOrderLine + 1
tmpSystemLine = tmpOrderLine
tmpATO = tmpATO + 1
tmpItemNo = 0
'check contents
'-------------------------------------------------
Set Systems = ProductHeader.NewChild("WBSBOMItem", "")
Systems.NewChild2 "WBSBOMParentName", ""
Systems.NewChild2 "WBSBOMProduct", tmpCabinet
Systems.NewChild2 "WBSBOMLineNumber", tmpTopLevel & "." & tmpATO
Systems.NewChild2 "WBSBOMQuantity", "1"
Systems.NewChild2 "WBSBOMRowID", tmpTopLevel & "." & tmpATO
Systems.NewChild2 "WBSBOMCustomerSupplied", ""
'lookup the cabinet description
On Error GoTo Skip2
x = Application.WorksheetFunction.VLookup(tmpCabinet, ws.Range("C5:D105"), 2, False)
Skip2:
Systems.NewChild2 "WBSBOMDescription", IIf(x <> 0, x, "")
Systems.NewChild2 "WBSBOMImportSource", ""
Systems.NewChild2 "WBSBOMMilestoneBillFlag", ""
Systems.NewChild2 "WBSBOMParentItemNumber", tmpTopLevel
Systems.NewChild2 "WBSBOMType", ""
Systems.NewChild2 "WBSBOMUnitCost", ""
Systems.NewChild2 "WBSBOMUnitOfMeasure", tmpCurr
Systems.NewChild2 "WBSBOMName", ""
Systems.NewChild2 "WBSBOMPackage", ""
Systems.NewChild2 "WBSBOMPkgDescription", ""
tmpSystem = ActiveCell.Offset(0, -1)
'-------------------------------------------------
ActiveCell.Offset(0, 0).Select
End If
ActiveCell.Offset(0, 4).Select
If ActiveCell.Value <> 0 Then
ActiveCell.Offset(0, -4).Select
Set Systems = ProductHeader.NewChild("WBSBOMItem", "")
tmpItemNo = tmpItemNo + 1
ActiveCell.Offset(0, 2).Select
Systems.NewChild2 "WBSBOMParentName", "" ' tmpPro & "_" & tmpSystemLine 'o 'TmpProType & "0" & tmpOrderLine
Systems.NewChild2 "WBSBOMProduct", UCase(ActiveCell.Value) 'rst![Lot_code_Sap] 'rst!Product
Systems.NewChild2 "WBSBOMLineNumber", tmpTopLevel & "." & tmpATO & "." & tmpItemNo
ActiveCell.Offset(0, 2).Select
Systems.NewChild2 "WBSBOMQuantity", ActiveCell.Value '1 'rst!Qty
Systems.NewChild2 "WBSBOMRowID", tmpTopLevel & "." & tmpATO & "." & tmpItemNo 'tmpSystemLine & "." & tmpItemNo 'tmpPro & "_" & tmpSystemLine & "." & tmpItemNo 'TmpProType & "0" & tmpOrderLine & "_" & tmpSystemLine & "." & tmpItemNo
Systems.NewChild2 "WBSBOMCustomerSupplied", ""
'gather cost for line
tmpCost = 0
ActiveCell.Offset(0, 1).Select
tmpCost = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Systems.NewChild2 "WBSBOMDescription", ActiveCell.Value
Systems.NewChild2 "WBSBOMImportSource", ""
Systems.NewChild2 "WBSBOMMilestoneBillFlag", ""
Systems.NewChild2 "WBSBOMParentItemNumber", tmpTopLevel & "." & tmpATO
Systems.NewChild2 "WBSBOMType", ""
Systems.NewChild2 "WBSBOMUnitCost", tmpCost
Systems.NewChild2 "WBSBOMUnitOfMeasure", tmpCurr
Systems.NewChild2 "WBSBOMName", ""
Systems.NewChild2 "WBSBOMPackage", ""
Systems.NewChild2 "WBSBOMPkgDescription", ""
ActiveCell.Offset(1, -7).Select
Else
ActiveCell.Offset(1, -5).Select
End If
tmpStr = ""
Else
tmpTest = False
End If
Loop
Application.ScreenUpdating = True
Range("A1").Select
tmpItemNo2 = tmpItemNo2 + 1
tmpName = ActiveWorkbook.Name
tmpName = Left(tmpName, (Len(tmpName) - 4))
' Save the XML:
Dim success As Long
success = xml.SaveXml("c:\SAPXML\V6_" & tmpName & ".xml")
If (success <> 1) Then
MsgBox xml.LastErrorText
End If
MsgBox ("c:\SAPXML\V6_" & tmpName & ".xml Created")
Exit_Func:
Set ProductHeader = Nothing
Set Systems = Nothing
Set System = Nothing
End Sub
Related Posts
Auto Unzipping Files and Loading of Excel Files
We used this function to automatically unzip Excel files ,...
SAP – Changing the format of downloaded files
The SAP system often downloads files as MHT which can...