VBA，宏中的分隔符

Question

需要拆分第 3 行并将其设置为以下 xml 格式。

我的 Excel 数据：

ID	EMail	用户组 ID
阿拉文	Aravind@gmail.com	运动（12-34）
阿拉文德2	Aravind2@gmail.com	体育(3-24-5)、健康(5-675-85)、教育(57-85-96)

我的 XML 数据：

<?xml version="1.0" encoding="utf-8"?>
<Core-data ContextID="Context1" WorkspaceID="Main">

<UserList>
<User ID="Aravind" ForceAuthentication="false" Password="1234" EMail="Aravind@gmail.com">
    <Name>Aravind</Name>
    <UserGroupLink UserGroupID="12-34"/>
  </User>
  <User ID="Aravind2" ForceAuthentication="false" Password="1234" EMail="Aravind@gmail.com">
    <Name>Aravind2</Name>
    <UserGroupLink UserGroupID="3-24-5"/>
    <UserGroupLink UserGroupID="5-675-85"/>
   <UserGroupLink UserGroupID="57-85-96"/>
   </User>
 </UserList>
 </Core-data>

我使用的代码：（仅需要更改第 3 行和位置的定界）

Sub Generate_xml()

Const FOLDER = "C:\Temp\"
Const XLS_FILE = "UserDataEntry.xlsm"
Const XML_FILE = "User XML.xml"

Const XML = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & _
             "<Core-data ContextID=""Context1"" WorkspaceID=""Main"">" & vbCrLf & _
             "  <UserList>" & vbCrLf
             
Dim wb As Workbook, ws As Worksheet, ar, s As String
Dim iLastRow As Long, r As Long, n As Integer

' open source workbook
Set wb = Workbooks.Open(FOLDER & XLS_FILE, 1, 1)
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

' create XML document
'<User ID="Aravind" ForceAuthentication="false" Password="1234" EMail="Aravind@gmail.com.com">
'    <Name>Aravind</Name>
'    <UserGroupLink UserGroupID="Sports"/>
'</User>
s = XML
For r = 2 To iLastRow
    s = s & "    <User ID=""" & ws.Cells(r, 1) & """" & _
        " ForceAuthentication=""false"" Password=""1234""" & _
        " EMail=""" & ws.Cells(r, 2) & """>" & vbCrLf
    s = s & "      <Name>" & ws.Cells(r, 1) & "</Name>" & vbCrLf
 
    ar = Split(ws.Cells(r, 3), ",")
    For n = LBound(ar) To UBound(ar)
        s = s & "      <UserGroupLink UserGroupID=""" & Trim(ar(n)) & """/>" & vbCrLf
    Next

    s = s & "    </User>" & vbCrLf
Next
s = s & "  </UserList>" & vbCrLf & "</Core-data>"

' save
Dim fso, ts
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.createtextfile(FOLDER & XML_FILE)
ts.write s
ts.Close
MsgBox "Xml created to " & FOLDER & XML_FILE

 End Sub

有什么方法可以在任何位置运行此 VBA 代码，并且生成的 XML 位于同一位置。 请提前分享您的意见和感谢。

Answer 1

尝试这样的事情：

Sub Generate_xml()

    Const FOLDER = "C:\Temp\"
    Const XLS_FILE = "UserDataEntry.xlsm"
    Const XML_FILE = "User XML.xml"
    Const XML = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & _
                 "<Core-data ContextID=""Context1"" WorkspaceID=""Main"">" & vbCrLf & _
                 "  <UserList>" & vbCrLf
                 
    Dim wb As Workbook, ws As Worksheet, s As String, savePath As String
    Dim r As Long, e
    
    ' open source workbook
    Set wb = Workbooks.Open(FOLDER & XLS_FILE, 1, 1)
    Set ws = wb.Sheets("Sheet1")
    
    ' create XML document
    s = XML
    For r = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
        s = s & "    <User ID=""" & ws.Cells(r, 1) & """" & _
            " ForceAuthentication=""false"" Password=""1234""" & _
            " EMail=""" & ws.Cells(r, 2) & """>" & vbCrLf
        s = s & "      <Name>" & ws.Cells(r, 1) & "</Name>" & vbCrLf
     
        For Each e In TextInParentheses(ws.Cells(r, 3).Value)
            s = s & "      <UserGroupLink UserGroupID=""" & Trim(e) & """/>" & vbCrLf
        Next e
    
        s = s & "    </User>" & vbCrLf
    Next
    s = s & "  </UserList>" & vbCrLf & "</Core-data>"
    
    'wb.Close false  'close source workbook
    
    ' save to same path as running code
    savePath = ThisWorkbook.Path & "\" & XML_FILE
    PutContent savePath, s
    MsgBox "Xml created at '" & savePath & "'", vbInformation

End Sub

'all texts enclosed in parentheses as a collection
Function TextInParentheses(txt As String)
    Dim re As Object
    Dim allMatches, m, col As New Collection
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\(([^\)]+)\)"
    re.ignorecase = True
    re.Global = True
    Set allMatches = re.Execute(txt)
    For Each m In allMatches
        col.Add Trim(m.submatches(0))
    Next m
    Set TextInParentheses = col
End Function

'Save text `content` to a text file at `f`
Sub PutContent(f As String, content As String)
    CreateObject("scripting.filesystemobject"). _
                  opentextfile(f, 2, True).write content
End Sub