返回列表 上一主題 發帖

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

dennislin

帖子
10 
主題
6 
精華
0 
積分
21 
點名
0  
作業系統
window xp 
軟體版本
2003 
閱讀權限
10 
註冊時間
2010-6-13 
最後登錄
2022-1-3 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-10-17 22:26 | 只看該作者

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

各位高手 好:

因為工作報告的關係，必須擷取一篇文章中各段落的某些文字，並計算次數。
想請教一下各位高手如何以函數或巨集設定某些文字，由各段落擷取出來。

例如，下面文章中(有三段落)設定要擷取的文字是"關節、骨頭"等，各段落經擷取後結果為，第一段:關節，第二段:骨頭、關節，第三段:骨頭、關節。

麻煩各位高手不吝告知，感謝。

   (第一段)民眾從歐美旅行歸國時常買「維骨力」孝敬長輩，但營養師提醒，「維骨力」功效是保護關節，成分並沒有鈣，別補錯了。

　(第二段)台北市立聯合醫院忠孝院區營養師洪若樸今天表示，許多民眾常搞不清楚保養骨頭及關節所需要的飲食。她在門診諮詢常被病人問，「骨質疏鬆要補維骨力嗎？一天吃幾顆？」

　(第三段)洪若樸指出，一般人看到維骨力中的「骨」字，就以為吃了可以「補骨」。但其實，最好將「骨頭」和「關節」搞清楚，基本上，「維骨力」是顧「關節」，成分中完全沒有鈣，如果拿維骨力來補鈣，就大錯特錯。
收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 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

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
277  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-12-23 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2013-10-18 14:36 | 只看該作者
回復 1# dennislin

B2=(LEN($A2)-LEN(SUBSTITUTE($A2,B$1,"")))/LEN(B$1)
   
學海無涯_不恥下問

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
4#
發表於 2013-10-18 14:48 | 只看該作者
回復 1# dennislin

B2
=(LEN($A2)-LEN(SUBSTITUTE($A2,B$1,)))/LEN(B$1)
又拉下拉複製公式

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

dennislin

帖子
10 
主題
6 
精華
0 
積分
21 
點名
0  
作業系統
window xp 
軟體版本
2003 
閱讀權限
10 
註冊時間
2010-6-13 
最後登錄
2022-1-3 

論壇贊助勳章
5#
發表於 2013-10-20 07:32 | 只看該作者
謝謝大家。另外，是否能將各段落內容，經函數或巨集擷取後的特定文字部分，呈現如附件所示，再請各位高手不吝告知。

TOP

dennislin

帖子
10 
主題
6 
精華
0 
積分
21 
點名
0  
作業系統
window xp 
軟體版本
2003 
閱讀權限
10 
註冊時間
2010-6-13 
最後登錄
2022-1-3 

論壇贊助勳章
6#
發表於 2013-10-20 07:34 | 只看該作者
回復 5# dennislin


    擷取特定文字.rar (4.24 KB)

不好意思，沒夾上附件。

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
7#
發表於 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

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