返回列表 上一主題 發帖

[發問] 想請教如何用VBA判斷關鍵字,並複製一列

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
1# 跳轉到 »
發表於 2014-12-21 22:50 | 顯示全部帖子
各位高手好,我想請教一下
我有一份關鍵字清單並已分類好
現在有一份課程名稱要來查詢出關鍵字
目前可查出 ...
hasrhgni 發表於 2014-12-19 16:51

我猜你的結果是要像 Sheet4 中所顯示的情形,
程式修改如下:
  1. Dim iCol%
  2.   Dim strSA$, strC$, strA$, strca$, Dilimiter$  '定義字串變數，用來承接範圍名稱

  4.   strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
  5.   strC = "keyword"        '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
  6.   strA = "Answer"       '用來承接答案的範圍名稱(紅色範圍)
  7.   strca = "catalog"
  8.   Dilimiter = ","       '用來做為區隔符號的變數，方便後續文書處理用

  10. For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
  11.     For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
  12.         If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
  13.             With Range(strA).Cells(i, 1)
  14.               iCol = .Offset(, Columns.Count - 2).End(xlToLeft).Column - 1
  15.               .Offset(, iCol) = Range(strC).Cells(j, 1).Offset(0, -1)
  16.             End With
  17.         End If
  18.     Next
  19. Next
複製代碼
如果你要的是 B 欄放全部鍵值,
但以 , 做區隔的話就改成底下這樣:
  1.   Dim strSA$, strC$, strA$, strca$, Dilimiter$  '定義字串變數，用來承接範圍名稱

  3.   strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
  4.   strC = "keyword"        '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
  5.   strA = "Answer"       '用來承接答案的範圍名稱(紅色範圍)
  6.   strca = "catalog"
  7.   Dilimiter = ","       '用來做為區隔符號的變數，方便後續文書處理用
  8.   
  9. For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
  10.     Range(strA).Cells(i, 1) = ""
  11.     For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
  12.         If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
  13.             With Range(strA).Cells(i, 1)
  14.               If .Value <> "" Then
  15.                 .Value = .Value & Dilimiter & Range(strC).Cells(j, 1).Offset(0, -1)
  16.               Else
  17.                 .Value = Range(strC).Cells(j, 1).Offset(0, -1)
  18.               End If
  19.             End With
  20.         End If
  21.     Next
  22. Next
複製代碼

TOP

luhpro

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

回復 4# hasrhgni
你的程式沒考慮到每當插入一列時,
對應的標的儲存格會有位移,
所以要用一個變數來存放此位移值並套用到應該隨之變更的數字上:
  1.   Dim strSA$, strC$, strA$, strca$, Dilimiter$  '定義字串變數，用來承接範圍名稱
  2.   Dim lIns& ' 插入列時的位移值

  4. strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
  5. strC = "keyword"        '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
  6. strA = "Answer"       '用來承接答案的範圍名稱(紅色範圍)
  7. strca = "catalog"
  8. Dilimiter = ","       '用來做為區隔符號的變數，方便後續文書處理用

  10. lIns = 0
  11. For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
  12.   Range(strA).Cells(i + lIns, 1) = "" '設定承接答案用的儲存格為空值，避免重複按按鈕時資料累加
  13.     For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
  14.         If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
  15.           With Range(strA).Cells(i + lIns, 1)
  16.             If .Value = "" Then  '若承接答案用的儲存格為空，則直接放入關鍵字
  17.                  .Value = Range(strC).Cells(j, 1).Offset(0, -1)
  18.             Else    '若不為空值則保留原來資料 插入分隔符號 再插入新資料
  19.                         With .EntireRow
  20.                           .Copy
  21.                           .Insert Shift:=xlDown
  22.                         End With
  23.                         .Value = Range(strC).Cells(j, 1).Offset(0, -1).Value
  24.                         lIns = lIns + 1
  25.             End If
  26.           End With
  27.         End If
  28.     Next
  29. Next
複製代碼

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
3#
發表於 2014-12-24 00:03 | 顯示全部帖子
luhpro 大師您好!
不知我是否可以加入個判斷,如果分類大於2筆時多複製一筆為"綜合類"
hasrhgni 發表於 2014-12-22 17:44

那就再加個變數囉:
  1.   Dim strSA$, strC$, strA$, strca$, Dilimiter$  '定義字串變數，用來承接範圍名稱
  2.   Dim lIns&, iCnt%  ' <=====加這行, 計算是否超過 2 個

  4. strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
  5. strC = "keyword"        '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
  6. strA = "Answer"       '用來承接答案的範圍名稱(紅色範圍)
  7. strca = "catalog"
  8. Dilimiter = ","       '用來做為區隔符號的變數，方便後續文書處理用

  10. lIns = 0
  11. For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
  12.   Range(strA).Cells(i + lIns, 1) = "" '設定承接答案用的儲存格為空值，避免重複按按鈕時資料累加
  13.   iCnt = 0 '<=====加這行, 歸零
  14.     For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
  15.         If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
  16.           With Range(strA).Cells(i + lIns, 1)
  17.             If .Value = "" Then  '若承接答案用的儲存格為空，則直接放入關鍵字
  18.               .Value = Range(strC).Cells(j, 1).Offset(0, -1)
  19.             Else    '若不為空值則保留原來資料 插入分隔符號 再插入新資料
  20.               With .EntireRow
  21.                 .Copy
  22.                 .Insert Shift:=xlDown
  23.               End With
  24.               .Value = Range(strC).Cells(j, 1).Offset(0, -1).Value
  25.               lIns = lIns + 1
  26.               iCnt = iCnt + 1 '<=====加這行, 計數值加 1
  27.             End If
  28.           End With
  29.         End If
  30.     Next
  31.   '<=====加這段-頭
  32.     If iCnt > 2 Then ' 超過 2 個加一行
  33.       With Range(strA).Cells(i + lIns, 1)
  34.         With .EntireRow
  35.           .Copy
  36.           .Insert Shift:=xlDown
  37.         End With
  38.         .Value = "綜合類"
  39.         lIns = lIns + 1
  40.       End With
  41.     End If
  42.   '<=====加這段-尾
  43. Next
複製代碼

TOP

        靜思自在 : 人生沒有所有權，只有生命的使用權。
返回列表 上一主題