[發問] 如何從一段文字選出字詞

iceandy6150

各位好
我有一個功能想做
就是每個人會有一段評語，也就是一段文字
但是我需要歸納出重點字詞

比如，評語是：善待動物有愛心，對人和氣，友愛同學，誠實不說謊
那我設按鈕，按下後會自動歸納出 ：有愛心、和氣、誠實

下載 (107.52 KB)

2019-7-27 21:43

但是每個字詞就要用一個IF去判斷
如果有20種不同的字詞，不就要寫20個IF ?

規則可能像我想的，
*愛* --> 有愛心
*誠* --> 誠實
*和* --> 待人和氣
*友* --> 友愛同學 ... 等等

有辦法用VLOOKUP那種方式，或是在 另一個工作表，弄出這些規則字詞
然後程式會自己去參照的?

因為每個人評語不見得相同
但是我就要規納成重點字詞，還要能串接起來

再請各位大大幫我想想
謝謝

選字詞.rar (16.06 KB)

下載次數: 6

2019-7-27 21:48

准提部林

Private Sub CommandButton1_Click()
Dim TR, TT$, T, TX$, xR As Range
TX = "愛+有愛心/和+待人和氣/誠+誠實/友+友愛同學/孝+孝順"
For Each xR In Range([工作表1!A1], [工作表1!A65536].End(xlUp))
    For Each T In Split(TX, "/")
        TR = Split(T, "+")
        If InStr(xR.Value, TR(0)) Then TT = TT & "、" & TR(1)
    Next
    xR(1, 3) = Mid(TT, 2): TT = ""
Next
End Sub


==================================

准提部林

對照表放E:F欄:

Private Sub CommandButton1_Click()
Dim Arr, TT$, T, xR As Range
Arr = Range([工作表1!E1], [工作表1!F65536].End(xlUp))
For Each xR In Range([工作表1!A1], [工作表1!A65536].End(xlUp))
    For i = 1 To UBound(Arr)
        If Arr(i, 1) <> "" And InStr(xR, Arr(i, 1)) Then TT = TT & "、" & Arr(i, 2)
    Next i
    xR(1, 3) = Mid(TT, 2): TT = ""
Next
End Sub


======================================

iceandy6150

回復 3# 准提部林


    感謝版主的解答
    兩種方式都可以作用
    太感謝了

iceandy6150

回復 3# 准提部林


    你好，我想請問一下
Private Sub CommandButton1_Click()
Dim Arr, TT$, T, xR As Range
Arr = Range([工作表1!E1], [工作表1!F65536].End(xlUp))
For Each xR In Range([工作表1!A1], [工作表1!A65536].End(xlUp))
    For i = 1 To UBound(Arr)
        If Arr(i, 1) <> "" And InStr(xR, Arr(i, 1)) Then TT = TT & "、" & Arr(i, 2)
    Next i
    xR(1, 3) = Mid(TT, 2): TT = ""
Next
End Sub

這是因為都在同一個工作表中
Arr = Range([工作表1!E1], [工作表1!F65536].End(xlUp))
如果我的對照表是在 工作表3
直接改成
Arr = Range([工作表3!E1], [工作表3!F65536].End(xlUp))
好像會錯ㄟ

另外是

我的程式明明就有 For 然後中間有很大一段的程式  才出現 Next
F8逐行偵錯的時候，就跟我說只有NEXT 沒有 FOR
快瘋了
WITH 跟 END WITH 也一樣

不曉得有沒有類似的經驗
到底錯誤在哪裡

謝謝

准提部林

回復 5# iceandy6150


問1)
Private Sub CommandButton1_Click()
Dim Arr, TT$, T, xR As Range, xS As Worksheet
Set xS = Sheets("工作表3")
Arr = xS.Range(xS.Range("E1"), xS.Range("F65536").End(xlUp))
For Each xR In xS.Range(xS.[A3], xS.[A65536].End(xlUp))
    For i = 1 To UBound(Arr)
        If Arr(i, 1) <> "" And InStr(xR, Arr(i, 1)) Then TT = TT & "、" & Arr(i, 2)
    Next i
    xR(1, 3) = Mid(TT, 2): TT = ""
Next
End Sub

問2)
要看完整的程式才可判斷錯在哪???

========================

iceandy6150

回復 6# 准提部林


    謝謝版主解答
原來還要設定這樣 Set xS = Sheets("工作表3")
我懂了

然後那個問題2
明明有FOR也有NEXT
卻警告錯誤

我上網找資料
發現如果 FOR 跟 NEXT 中間的程式 如果有用到IF 但卻忘記給 END IF
電腦卻只會笨笨的警告你FOR 跟NEXT錯了
不會去裡面找出缺了ENDIF
後來我就找到我程式錯誤的地方了

感謝