html vba 单元格 格式,怎么处理单元格中HTML数据

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

'根据行列数定义数组

ReDim arr(0 To lngRows, 1 To lngCols) As String

'首行

For lngC = 1 To lngCols

arr(0, lngC) = strId

arr(1, lngC) = strCols(lngC - 1)

Next

lngCurRowID = 2

For lngR = 1 To lngRows - 1

strCols = Split(RegExpTest(strRows(lngR), "

([\s\S]*?)

If UBound(strCols) <= lngCountCols Then

For lngC = 1 To UBound(strCols) + 1

arr(lngCurRowID, lngC) = strCols(lngC - 1)

Next

End If

lngCurRowID = lngCurRowID + 1

Next

GetValue = arr

End Function

Function RegExpTest(strVal As String, strPat As String) As String

Dim regEX, match, matches

Dim strTemp As String

Set regEX = CreateObject("VBSCRIPT.REGEXP")

regEX.Pattern = strPat

regEX.IgnoreCase = True

regEX.Global = True

Set matches = regEX.Execute(strVal)

For Each match In matches

strTemp = strTemp & "|" & match.submatches(0)

Next

RegExpTest = Mid(strTemp, 2)

End Function