返回列表 上一主題 發帖

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

hasrhgni

帖子
8 
主題
2 
精華
0 
積分
10 
點名
0  
作業系統
win7 
軟體版本
office 2007 
閱讀權限
10 
性別
男 
來自
桃園 
註冊時間
2014-12-12 
最後登錄
2016-4-13 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-12-19 16:51 | 只看該作者

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

vba
本帖最後由 hasrhgni 於 2014-12-19 16:54 編輯

各位高手好,我想請教一下
我有一份關鍵字清單並已分類好
現在有一份課程名稱要來查詢出關鍵字
目前可查出關鍵字後顯示在右欄並用","逗號分開並補上第二個關鍵字
但我現在想將查出的關鍵字第一次結果顯示在右欄並將第二個關鍵字能夠往下複製同一列後並在右欄顯示第二個關鍵字(複製後的第一個關鍵字蓋過去)
如果查出有三次結果就往下複製三列
不知我該如何寫,我卡很久了!!!
Sub Macro1()
Dim strSA As String      '定義字串變數，用來承接範圍名稱
Dim strC As String
Dim strA As String
Dim strca As String
Dim Dilimiter As String

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


For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
'第一個迴圈代表從第一筆字串搜尋到到最後一筆字串

  Range(strA).Cells(i, 1).Value = ""   '設定承接答案用的儲存格為空值，避免重複按按鈕時資料累加

    For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
    '第二個迴圈代表從第一個關鍵字開始尋找 到最後一個關鍵字

        If InStr(Range(strSA).Cells(i, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
        
            ' InStr(S,F)為傳回F字串在S字串中的第幾個字，若無則傳回 0
            '.Cells(row,column)為儲存格中的相對位置 .Value為儲存格中的值
            
            If Range(strA).Cells(i, 1).Value = "" Then  '若承接答案用的儲存格為空，則直接放入關鍵字
                 
                 Range(strA).Cells(i, 1).Value = Range(strC).Cells(j, 1).Offset(0, -1).Value
                 
            Else    '若不為空值則保留原來資料 插入分隔符號 再插入新資料
                        
                        Range(strA).Cells(i, 1).Value = Range(strA).Cells(i, 1).Value
                        ActiveCell.Rows("1:1").EntireRow.Select
                        Selection.Copy
                        Selection.Insert Shift:=xlDown
                        Range(strA).Cells(i, 1).Select
                        ActiveCell.Value = Range(strC).Cells(j, 1).Offset(0, -1).Value
                        Range(strA).Cells(i, 1).Select
                        

            End If
        End If
    Next
Next

End Sub
201407-12_list2.zip (132.41 KB)
收藏 分享
努力學習

luhpro

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

hasrhgni

帖子
8 
主題
2 
精華
0 
積分
10 
點名
0  
作業系統
win7 
軟體版本
office 2007 
閱讀權限
10 
性別
男 
來自
桃園 
註冊時間
2014-12-12 
最後登錄
2016-4-13 
3#
發表於 2014-12-21 23:56 | 只看該作者
非常感謝 luhpro  的幫忙,那確實是我要的,但我不知是否還有方式,能將第C欄和之後的欄出現後的關鍵字能:
1.自動複制A欄後並插入一列
2.並將C欄的關鍵字補在B欄
這樣就只有2欄的資料,A欄會因B欄所出現的關鍵字自動新增A欄的課程名稱
努力學習

TOP

hasrhgni

帖子
8 
主題
2 
精華
0 
積分
10 
點名
0  
作業系統
win7 
軟體版本
office 2007 
閱讀權限
10 
性別
男 
來自
桃園 
註冊時間
2014-12-12 
最後登錄
2016-4-13 
4#
發表於 2014-12-22 00:00 | 只看該作者
非常感謝 luhpro  的幫忙,那確實是我要的,但我不知是否還有方式,能將第C欄和之後的欄出現後的關鍵字能:
1.自動複制A欄後並插入一列
2.並將C欄的關鍵字補在B欄
這樣就只有2欄的資料,A欄會因B欄所出現的關鍵字自動新增A欄的課程名稱

課程名稱       
牙周病科雜誌暨病例討論會                 綜合類
牙周病科雜誌暨病例討論會                牙周病類
齒顎矯正科雜誌暨病例討論會                牙齒矯正類
齒顎矯正科雜誌暨病例討論會                綜合類
牙髓病科雜誌討論會暨病例討論會       綜合類
口腔顎面外科雜誌討論會                口腔外科學類
牙體復形科雜誌討論會                口腔補綴學
努力學習

TOP

luhpro

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

hasrhgni

帖子
8 
主題
2 
精華
0 
積分
10 
點名
0  
作業系統
win7 
軟體版本
office 2007 
閱讀權限
10 
性別
男 
來自
桃園 
註冊時間
2014-12-12 
最後登錄
2016-4-13 
6#
發表於 2014-12-22 00:59 | 只看該作者
這確實就是我要的,我要跪拜您這位大師了!
太感恩了,謝謝!!!
努力學習

TOP

hasrhgni

帖子
8 
主題
2 
精華
0 
積分
10 
點名
0  
作業系統
win7 
軟體版本
office 2007 
閱讀權限
10 
性別
男 
來自
桃園 
註冊時間
2014-12-12 
最後登錄
2016-4-13 
7#
發表於 2014-12-22 17:44 | 只看該作者
luhpro 大師您好!
不知我是否可以加入個判斷,如果分類大於2筆時多複製一筆為"綜合類"
努力學習

TOP

luhpro

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

hasrhgni

帖子
8 
主題
2 
精華
0 
積分
10 
點名
0  
作業系統
win7 
軟體版本
office 2007 
閱讀權限
10 
性別
男 
來自
桃園 
註冊時間
2014-12-12 
最後登錄
2016-4-13 
9#
發表於 2014-12-25 23:05 | 只看該作者
真是太感謝 luhpro 大師了!
努力學習

TOP

        靜思自在 : 受人點水之恩，須當湧泉以報。
返回列表 上一主題