麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 想請教如何用VBA判斷關鍵字,並複製一列 [打印本頁]

作者: hasrhgni 時間: 2014-12-19 16:51 標題: 想請教如何用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
[attach]19867[/attach]

作者: luhpro 時間: 2014-12-21 22:50

各位高手好,我想請教一下
我有一份關鍵字清單並已分類好
現在有一份課程名稱要來查詢出關鍵字
目前可查出 ...
hasrhgni 發表於 2014-12-19 16:51

我猜你的結果是要像 Sheet4 中所顯示的情形,
程式修改如下:

Dim iCol%
Dim strSA$, strC$, strA$, strca$, Dilimiter$ '定義字串變數，用來承接範圍名稱
strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
strC = "keyword" '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
strA = "Answer" '用來承接答案的範圍名稱(紅色範圍)
strca = "catalog"
Dilimiter = "," '用來做為區隔符號的變數，方便後續文書處理用
For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
With Range(strA).Cells(i, 1)
iCol = .Offset(, Columns.Count - 2).End(xlToLeft).Column - 1
.Offset(, iCol) = Range(strC).Cells(j, 1).Offset(0, -1)
End With
End If
Next
Next

複製代碼

如果你要的是 B 欄放全部鍵值,
但以 , 做區隔的話就改成底下這樣:

Dim strSA$, strC$, strA$, strca$, Dilimiter$ '定義字串變數，用來承接範圍名稱
strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
strC = "keyword" '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
strA = "Answer" '用來承接答案的範圍名稱(紅色範圍)
strca = "catalog"
Dilimiter = "," '用來做為區隔符號的變數，方便後續文書處理用
For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
Range(strA).Cells(i, 1) = ""
For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
With Range(strA).Cells(i, 1)
If .Value <> "" Then
.Value = .Value & Dilimiter & Range(strC).Cells(j, 1).Offset(0, -1)
Else
.Value = Range(strC).Cells(j, 1).Offset(0, -1)
End If
End With
End If
Next
Next

複製代碼

作者: hasrhgni 時間: 2014-12-21 23:56

非常感謝 luhpro 的幫忙,那確實是我要的,但我不知是否還有方式,能將第C欄和之後的欄出現後的關鍵字能:
1.自動複制A欄後並插入一列
2.並將C欄的關鍵字補在B欄
這樣就只有2欄的資料,A欄會因B欄所出現的關鍵字自動新增A欄的課程名稱

作者: hasrhgni 時間: 2014-12-22 00:00

非常感謝 luhpro  的幫忙,那確實是我要的,但我不知是否還有方式,能將第C欄和之後的欄出現後的關鍵字能:
1.自動複制A欄後並插入一列
2.並將C欄的關鍵字補在B欄
這樣就只有2欄的資料,A欄會因B欄所出現的關鍵字自動新增A欄的課程名稱

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

作者: luhpro 時間: 2014-12-22 00:37

本帖最後由 luhpro 於 2014-12-22 00:40 編輯

回復 4# hasrhgni
你的程式沒考慮到每當插入一列時,
對應的標的儲存格會有位移,
所以要用一個變數來存放此位移值並套用到應該隨之變更的數字上:

Dim strSA$, strC$, strA$, strca$, Dilimiter$ '定義字串變數，用來承接範圍名稱
Dim lIns& ' 插入列時的位移值
strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
strC = "keyword" '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
strA = "Answer" '用來承接答案的範圍名稱(紅色範圍)
strca = "catalog"
Dilimiter = "," '用來做為區隔符號的變數，方便後續文書處理用
lIns = 0
For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
Range(strA).Cells(i + lIns, 1) = "" '設定承接答案用的儲存格為空值，避免重複按按鈕時資料累加
For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
With Range(strA).Cells(i + lIns, 1)
If .Value = "" Then '若承接答案用的儲存格為空，則直接放入關鍵字
.Value = Range(strC).Cells(j, 1).Offset(0, -1)
Else '若不為空值則保留原來資料插入分隔符號再插入新資料
With .EntireRow
.Copy
.Insert Shift:=xlDown
End With
.Value = Range(strC).Cells(j, 1).Offset(0, -1).Value
lIns = lIns + 1
End If
End With
End If
Next
Next

複製代碼

作者: hasrhgni 時間: 2014-12-22 00:59

這確實就是我要的,我要跪拜您這位大師了!
太感恩了,謝謝!!!

作者: hasrhgni 時間: 2014-12-22 17:44

luhpro 大師您好!
不知我是否可以加入個判斷,如果分類大於2筆時多複製一筆為"綜合類"

作者: luhpro 時間: 2014-12-24 00:03

luhpro 大師您好!
不知我是否可以加入個判斷,如果分類大於2筆時多複製一筆為"綜合類"
hasrhgni 發表於 2014-12-22 17:44

那就再加個變數囉:

Dim strSA$, strC$, strA$, strca$, Dilimiter$ '定義字串變數，用來承接範圍名稱
Dim lIns&, iCnt% ' <=====加這行, 計算是否超過 2 個
strSA = "class_name" '待搜尋字串的範圍名稱(橘色範圍)
strC = "keyword" '欲在(紅色範圍)中搜尋的關鍵字(藍色範圍)
strA = "Answer" '用來承接答案的範圍名稱(紅色範圍)
strca = "catalog"
Dilimiter = "," '用來做為區隔符號的變數，方便後續文書處理用
lIns = 0
For i = 1 To Range(strSA).Rows.Count 'Range("範圍名稱")就是一個工作表中的"範圍名稱"所代表的範圍
Range(strA).Cells(i + lIns, 1) = "" '設定承接答案用的儲存格為空值，避免重複按按鈕時資料累加
iCnt = 0 '<=====加這行, 歸零
For j = 1 To Range(strC).Rows.Count '.Rows.Count 為總資料行數
If InStr(Range(strSA).Cells(i + lIns, 1), Range(strC).Cells(j, 1).Value) <> 0 Then
With Range(strA).Cells(i + lIns, 1)
If .Value = "" Then '若承接答案用的儲存格為空，則直接放入關鍵字
.Value = Range(strC).Cells(j, 1).Offset(0, -1)
Else '若不為空值則保留原來資料插入分隔符號再插入新資料
With .EntireRow
.Copy
.Insert Shift:=xlDown
End With
.Value = Range(strC).Cells(j, 1).Offset(0, -1).Value
lIns = lIns + 1
iCnt = iCnt + 1 '<=====加這行, 計數值加 1
End If
End With
End If
Next
'<=====加這段-頭
If iCnt > 2 Then ' 超過 2 個加一行
With Range(strA).Cells(i + lIns, 1)
With .EntireRow
.Copy
.Insert Shift:=xlDown
End With
.Value = "綜合類"
lIns = lIns + 1
End With
End If
'<=====加這段-尾
Next

複製代碼

作者: hasrhgni 時間: 2014-12-25 23:05

真是太感謝 luhpro 大師了!

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)