返回列表 上一主題 發帖

[發問] 請教如何擷取文章中各段落的某些文字??

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
1# 跳轉到 »
發表於 2013-10-18 00:34 | 顯示全部帖子
各位高手 好:

因為工作報告的關係，必須擷取一篇文章中各段落的某些文字，並計算次數。
想請教一下各位 ...
dennislin 發表於 2013-10-17 22:26
  1. Sub nn()
  2.   Dim iI%
  3.   Dim sStr(1 To 3) As String, sSer$
  4.   Dim lPos1&, lNum1&, lPos2&, lNum2&, lLen&
  5.   
  6.   sStr(1) = "民眾從歐美旅行歸國時常買「維骨力」孝敬長輩，但營養師提醒，「維骨力」功效是保護關節，成分並沒有鈣，別補錯了。"
  7.   sStr(2) = "台北市立聯合醫院忠孝院區營養師洪若樸今天表示，許多民眾常搞不清楚保養骨頭及關節所需要的飲食。她在門診諮詢常被病人問，「骨質疏鬆要補維骨力嗎？一天吃幾顆？」"
  8.   sStr(3) = "洪若樸指出，一般人看到維骨力中的「骨」字，就以為吃了可以「補骨」。但其實，最好將「骨頭」和「關節」搞清楚，基本上，「維骨力」是顧「關節」，成分中完全沒有鈣，如果拿維骨力來補鈣，就大錯特錯。"
  9.   sSer = ""
  10.   For iI = 1 To 3
  11.     lLen = Len(sStr(iI))
  12.     lNum1 = 0
  13.     lNum2 = 0
  14.     lPos1 = 1
  15.     lPos2 = 1
  16.     Do While lPos1 <> 0 Or lPos2 <> 0
  17.       If lPos1 > 0 Then
  18.         If lPos1 = 1 Then lPos1 = 0
  19.         lPos1 = InStr(lPos1 + 1, sStr(iI), "關節")
  20.         If lPos1 <> 0 Then lNum1 = lNum1 + 1
  21.       End If
  22.       If iI > 1 Then
  23.         If lPos2 > 0 Then
  24.           If lPos2 = 1 Then lPos2 = 0
  25.           lPos2 = InStr(lPos2 + 1, sStr(iI), "骨頭")
  26.           If lPos2 <> 0 Then lNum2 = lNum2 + 1
  27.         End If
  28.       Else
  29.         lPos2 = 0
  30.       End If
  31.     Loop
  32.     If sSer <> "" Then sSer = sSer & Chr(10) & Chr(10)
  33.     sSer = sSer & "第 " & iI & " 段 : "
  34.     If iI > 1 Then sSer = sSer & "(骨頭) 找到 " & lNum2 & " 次, "
  35.    
  36.     sSer = sSer & "(關節) 找到 " & lNum1 & " 次"
  37.   Next iI
  38.   MsgBox sSer
  39. End Sub
複製代碼
有一點須留意的 : InStr 的字串搜尋起始位置不得為 0

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
2#
發表於 2013-10-20 20:16 | 顯示全部帖子
本帖最後由 luhpro 於 2013-10-20 20:18 編輯

回復 6# dennislin
依照欲擷取的文字於字串中出現的順序依序顯示出來 :
  1. Private Sub cbCatch_Click()
  2.   Dim iI%, iK%
  3.   Dim lPos&, lLen&, lRows&
  4.   Dim sSer$, sStr$, sCat() As String
  5.   
  6.   lRows = 3
  7.   Do While Cells(lRows, 1) <> ""
  8.     For iI = 2 To 3
  9.       sCat = Split(Cells(2, iI), "、")
  10.       sStr = Cells(lRows, 1)
  11.       lLen = Len(sStr)
  12.       For lPos = 1 To lLen
  13.         For iK = 0 To UBound(sCat)
  14.           If Mid(sStr, lPos, Len(sCat(iK))) = sCat(iK) Then
  15.             sSer = Cells(lRows, iI)
  16.             If sSer <> "" Then sSer = sSer & "、"
  17.             sSer = sSer & sCat(iK)
  18.             Cells(lRows, iI) = sSer
  19.             lPos = lPos + 1
  20.           End If
  21.         Next iK
  22.       Next lPos
  23.     Next iI
  24.     lRows = lRows + 1
  25.   Loop
  26. End Sub
複製代碼
擷取特定文字-a.zip (12.01 KB)

TOP

        靜思自在 : 盡多少本份，就得多少本事。
返回列表 上一主題