leiru

帖子: 334
主題: 139
精華: 0
積分: 621
點名: 0
作業系統: WINDOWSXP
軟體版本: OFFICE2003
閱讀權限: 50
性別: 女
來自: 台北縣
註冊時間: 2010-8-5
最後登錄: 2022-11-3

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2021-11-8 10:09 | 只看該作者

Ｂ欄要取出符合Ｄ欄內的關鍵字

Ｂ欄要取出符合Ｄ欄內的關鍵字，請問如何設定公式，謝謝。

Ｂ欄要取出符合Ｄ欄內的關鍵字.zip (22 Bytes)

樓主熱帖

joyce

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

9^#

發表於 2023-12-11 08:14 | 只看該作者

謝謝論壇,謝謝各位前輩
後學藉此帖練習VBA,學習方案如下,請各位前輩指教
執行前:

執行結果:

Option Explicit
Sub TEST()
Dim Brr, Crr, i&, x%, T$, T1$
Brr = Range([D2], [D65536].End(3))
Crr = Range([A2], [A65536].End(3))
For i = 1 To UBound(Crr)
T = Crr(i, 1)
Crr(i, 1) = ""
For x = 1 To UBound(Brr)
   T1 = Trim(Brr(x, 1)): If T1 = "" Then GoTo x01
   If InStr(T, T1) Then
      Crr(i, 1) = IIf(Crr(i, 1) = "", T1, Crr(i, 1) & "、" & T1)
   End If
x01: Next
Next
[C2].Resize(UBound(Crr), 1) = Crr
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

8^#

發表於 2021-11-10 21:07 | 只看該作者

如果excel版本沒有TEXTJOIN函數, 用vba寫個類似的自訂函數:

Xl0000808.rar (11.15 KB)

公式//陣列
=TEXTJOIN("、",1,IF(1-ISERR(0/(FIND(D$2:D$16,"_"&A2)>1)),D$2:D$16,""))

TOP

hcm19522

大學生 Rank: 4

帖子: 1387
主題: 4
精華: 0
積分: 1397
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-11-22

熱烈參與勳章

7^#

發表於 2021-11-9 15:45 | 只看該作者

本帖最後由 hcm19522 於 2021-11-9 15:53 編輯

回復 6# leiru

已成區域陣列 B2:B7先一起刪 B2重新在右拉下拉
A5 多個 3

google"EXCEL迷" blog 或google網址:https://hcm19522.blogspot.com/

TOP

leiru

高中生 Rank: 3 Rank: 3

帖子: 334
主題: 139
精華: 0
積分: 621
點名: 0
作業系統: WINDOWSXP
軟體版本: OFFICE2003
閱讀權限: 50
性別: 女
來自: 台北縣
註冊時間: 2010-8-5
最後登錄: 2022-11-3

6^#

發表於 2021-11-9 15:31 | 只看該作者

回復 5# hcm19522

請問我照公式設定,mark範圍B2:E7,
在B2儲存格輸入=IFERROR(IF(COLUMN(A1)=1,"","、")&INDEX($D:$D,SMALL(IF(ISNUMBER(0/(FIND($D$10:$D$18,"@"&$A2)-1)),ROW($10:$18)),COLUMN(A1)))&C2,"")
按ctrl+shift+enter

但沒顯示出希望結果

Ｂ欄要取出符合Ｄ欄內的關鍵字.zip (8.07 KB)

joyce

TOP

hcm19522

大學生 Rank: 4

帖子: 1387
主題: 4
精華: 0
積分: 1397
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-11-22

熱烈參與勳章

5^#

發表於 2021-11-8 16:12 | 只看該作者

https://blog.xuite.net/hcm19522/twblog/590110909

google"EXCEL迷" blog 或google網址:https://hcm19522.blogspot.com/

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

4^#

發表於 2021-11-8 13:33 | 只看該作者

回復 3# leiru

Sub test()
Dim Arr, xD, Reg, xE, T$, T1$, i%, j%, a
Set xD = CreateObject("Scripting.Dictionary")
Set Reg = CreateObject("VBScript.RegExp")
Arr = Range([d1], [d65536].End(3))
For i = 2 To UBound(Arr): T = Arr(i, 1): xD(T) = "": Next
Arr = Range([b1], [a65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1)
With Reg
      .Global = True
      .IgnoreCase = True
      .Pattern = "[\u4e00-\u9fa5()]+"
      Set xE = .Execute(T)
      a = Split(Trim(.Replace(T, "")), "、")
      For j = 0 To UBound(a)
         If Left(a(j), 2) <> "AA" Then
            pos = InStr(1, a(j), "AA")
            T = Mid(a(j), pos, Len(a(j)))
         Else
            T = a(j)
         End If
         If xD.Exists(T) Then: T1$ = T1$ & "、" & T
      Next
      Arr(i, 2) = Mid(T1, 2): T1 = ""
End With
Next
[a1].Resize(UBound(Arr), 2) = Arr
End Sub

TOP

leiru