Vậy thì toàn bộ code của bạn như sau (Kể cả mình chuyển Sub Demo1 thành hàm Demo)
Mã:
Option Explicit
'---------------------------------
Sub ProcessDT()
Dim ShRou As Worksheet, ShDes As Worksheet, ClRou As Range, ClDes As Range, ClSave As Range
Dim Tm(), i
Set ShRou = Workbooks("search_result 8IS6").Worksheets("search_result 8IS6")
Set ShDes = Workbooks("sample").Worksheets("sample")
Set ClRou = ShRou.[Q1]
Set ClDes = ShDes.[B1]
ShDes.Cells.ClearContents
Do While ClRou.Value <> ""
ClDes.Value = ClRou.Value
Set ClSave = ShDes.Cells(ShDes.Rows.Count, "E").End(xlUp)
If ClSave.Value <> "" Then ClSave = ClSave.Offset(1)
Tm = Demo(ClDes.Value)
ClSave.Resize(UBound(Tm)) = Tm
Set ClRou = ClRou.Offset(1)
Set ClDes = ClDes.Offset(1)
Loop
Set ShRou = Nothing: Set ShDes = Nothing
Set ClRou = Nothing: Set ClDes = Nothing: Set ClSave = Nothing
End Sub
'----------------------------------------
Function Demo(Ch As String)
Dim Spq, U&, R&, N&, S&, ST
Spq = Split(Replace(Ch, ">", ">?"), "?")
U = UBound(Spq)
While R < U
If Spq(R) Like "<*" Then
R = R + 1
Else
Spq(R - 1) = Spq(R - 1) & Spq(R)
U = U - 1
For N& = R To U: Spq(N) = Spq(N + 1): Next
End If
Wend
For R = 0 To U - 1
If Spq(R) Like "</*" Then
S = Left$(S, Len(S) - 2)
Spq(R) = S & Spq(R)
Else
ST = Split(Spq(R), "<")
Spq(R) = S & Spq(R)
If Not (Spq(R) Like "*/>" Or ST(UBound(ST)) Like "/*") Then S = S & " "
End If
Next
Demo = Application.Transpose(Spq)
End Function