Option Explicit
Sub Main()
Dim varTemp As Variant
Dim lngCurRow As Long '填充的起始行
Dim lngCountRows As Long '要读取据的总行数
Dim lngI As Long
lngCurRow = 2 '从第二行开始填充
lngCountRows = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Cursor = xlWait
For lngI = 2 To lngCountRows
varTemp = GetValue(Sheet1.Range("B" & lngI).Value, Sheet1.Range("A" & lngI).Value)
Sheet3.Range("A" & lngCurRow).Resize(UBound(varTemp, 2), UBound(varTemp) + 1) = Application.WorksheetFunction.Transpose(varTemp)
lngCurRow = lngCurRow + UBound(varTemp, 2)
Next
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "数据解析成功!", vbInformation + vbOKOnly
End Sub
Function GetValue(strSource As String, strId As String) As Variant
Dim arr() As String
Dim strRows() As String
Dim strCols() As String
Dim lngRows As Long, lngCols As Long
Dim lngR As Long, lngC As Long
Dim lngCountCols As Long '按标题列固定列数
Dim lngCurRowID As Long '当前行号
'取得行数
strRows = Split(RegExpTest(strSource, "(
lngRows = UBound(strRows) + 1
'取得列数
strCols = Split(RegExpTest(strRows(0), "
([\s\S]*?)
lngCols = UBound(strCols) + 1
lngCountCols = lngCols '记录列数
'没有有效记录,退出
If lngRows <1 Or lngCols <1 Then Exit Function
&#39;根据行列数定义数组
ReDim arr(0 To lngRows, 1 To lngCols) As String
&#39;首行
For lngC &#61; 1 To lngCols
arr(0, lngC) &#61; strId
arr(1, lngC) &#61; strCols(lngC - 1)
Next
lngCurRowID &#61; 2
For lngR &#61; 1 To lngRows - 1
strCols &#61; Split(RegExpTest(strRows(lngR), "
([\s\S]*?)
If UBound(strCols) <&#61; lngCountCols Then
For lngC &#61; 1 To UBound(strCols) &#43; 1
arr(lngCurRowID, lngC) &#61; strCols(lngC - 1)
Next
End If
lngCurRowID &#61; lngCurRowID &#43; 1
Next
GetValue &#61; arr
End Function
Function RegExpTest(strVal As String, strPat As String) As String
Dim regEX, match, matches
Dim strTemp As String
Set regEX &#61; CreateObject("Vbscript.REGEXP")
regEX.Pattern &#61; strPat
regEX.IgnoreCase &#61; True
regEX.Global &#61; True
Set matches &#61; regEX.Execute(strVal)
For Each match In matches
strTemp &#61; strTemp & "|" & match.submatches(0)
Next
RegExpTest &#61; Mid(strTemp, 2)
End Function