Board logo

標題: [發問] 多筆EXCEL搜尋的用法[已解決 2011-05-11] [打印本頁]
作者: mark15jill    時間: 2011-5-10 10:28     標題: 多筆EXCEL搜尋的用法[已解決 2011-05-11]

本帖最後由 mark15jill 於 2011-5-11 15:06 編輯

如題..
因資料數很多，想說用一個EXCEL VBA 將其關鍵字搜尋出來 並且 另存一份新的EXCEL檔案
如附檔...
[attach]6094[/attach]

方便的話，能否在能更改的地方加註一下，感恩!!
因有爬文 但是都只有 部份相關的資訊 並無統整的..
如看不懂 所附的檔案 請告知
作者: GBKEE    時間: 2011-5-10 11:01

本帖最後由 GBKEE 於 2011-5-10 11:04 編輯

回復 1# mark15jill
需求說明：
   1.想利用 在text內 輸入查詢的鄉鎮(如 台灣 )  再按 查詢 查詢的結果從 第三列(A3)開始將該資料列出來。
     如範例：要查詢 台灣 的話        (資料順序並非按照 123 這樣下去  有可能是跳號 20   25  30 27 等等。   
你的檔案是簡略的範例    請問:
1.要搜尋的檔案是同一目錄下的檔案嗎?  ,存檔在同一目錄下嗎?
2.資料號碼 是找到 台灣的列號嗎?    台灣 同一列往右有資料嗎? 要一起抓嗎?
3.範例 可以再實際些嗎?
作者: Hsieh    時間: 2011-5-10 11:12

是要將各年度活頁簿中，每個工作表的I欄，符合關鍵字條件的資料全部找出來
然後把這些資料的出處資料另存活頁簿嗎?
實在看不懂你的範例，要如何與你的說明配合起來
請將各年度檔案填入數據
然後把想要的結果樣式做成工作表，再配合說明
作者: mark15jill    時間: 2011-5-10 11:23

本帖最後由 mark15jill 於 2011-5-10 11:30 編輯

回復 2# GBKEE

抱歉 是我表達不好
在這說一次..
再查詢的活頁簿內的 TEXT 輸入 所要查詢的字樣
然後 按下查詢的COMBO的按鈕
則將  97  98 99 年度 所符合的 地址(例如台灣字眼的) 列在 A3 那列  (相關的案例 有重附上檔案)
列出的資料 包含 該資料的所有 “列資料 - 如第一筆的話就是 在a3 b3 c3 d3 e3 這一列 ”
然後 如果按下儲存的按鈕
就會將 查詢的字樣 儲存為新的活頁簿  (目錄路徑與查詢的目錄同一個)  EXCEL檔案及活頁簿 名稱為 查詢的字樣
如 查詢 台灣
則 台灣 這個EXCEL名稱 和 活頁簿名稱 均為 台灣   儲存路徑 與 “查詢 EXCEL檔案” 同樣目錄
不曉得這樣是否比較清楚..



我在重附一份格式的資料(大概格式)

    [attach]6095[/attach]
作者: GBKEE    時間: 2011-5-10 14:54

回復 4# mark15jill
  1. Private Sub 查詢()
  2.     Dim Text$, File$, TheSh As Object, Sh As Worksheet, Rng As Range, RngAddress$
  3.     With ThisWorkbook            '程式碼置於查詢總表.xls
  4.         Set TheSh = .Sheets("查詢")
  5.         TheSh.UsedRange.Offset(2).Clear
  6.         File = Dir(.Path & "\*年度*.xls")
  7.         Do While File <> ""
  8.             With Workbooks.Open(.Path & "\" & File)
  9.                 For Each Sh In .Sheets
  10.                     Set Rng = Sh.Range("e:e").Find(TheSh.TextBox1, LookAt:=xlWhole)
  11.                     If Not Rng Is Nothing Then
  12.                         RngAddress = Rng.Address
  13.                         With TheSh.Range("C" & Rows.Count).End(xlUp)
  14.                             .Offset(1, -2) = File
  15.                             .Offset(1, -1) = Sh.Name
  16.                         End With
  17.                     End If
  18.                     Do While Not Rng Is Nothing
  19.                         With TheSh.Range("C" & Rows.Count).End(xlUp)
  20.                             .Offset(1).Resize(1, 6) = Sh.Range(Sh.Cells(Rng.Row, "A"), Sh.Cells(Rng.Row, "F")).Value
  21.                         End With
  22.                         Set Rng = Sh.Range("e:e").FindNext(Rng)
  23.                         If RngAddress = Rng.Address Then Exit Do
  24.                     Loop
  25.                 Next
  26.             .Close 0
  27.             End With
  28.             File = Dir
  29.         Loop
  30.     End With
  31. End Sub
  32. Sub 存檔()              '程式碼置於查詢總表.xls
  33.     Dim Sh As Object
  34.     On Error Resume Next
  35.     Set Sh = ThisWorkbook.Sheets(1)
  36.    
  37.     With Workbooks.Add(xlWBATWorksheet)
  38.         Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]
  39.         .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1
  40.         .Close 0
  41.     End With
  42. End Sub
複製代碼
作者: mark15jill    時間: 2011-5-10 15:16

本帖最後由 mark15jill 於 2011-5-10 15:21 編輯

回復 5# GBKEE

GBKEE 大大不好意思 剛剛測試
發現以下幾個問題
1.控制鈕 變成無效 (僅能巨集控制)
2.存檔仍然有疑惑 無存檔動作
3.如果條件改成 美國的話 (預設是台灣)  就沒辦法有存檔的動作出現

順帶一問..
我那個按鈕弄對嗎= =!! 因為 有ACTIVE 和 另外一種  我常常都會搞混

附上測試後的資料夾

[attach]6100[/attach]
作者: GBKEE    時間: 2011-5-10 15:37

本帖最後由 GBKEE 於 2011-5-10 15:42 編輯

回復 6# mark15jill
1.控制鈕 變成無效 (僅能巨集控制)
指定按鈕巨集  請看如圖

[attach]6101[/attach]
Sub 存檔()               -> 公用會顯示
Private Sub 查詢()    -> 私用(Private)不會顯示
要用: 依樣畫葫蘆 打上 Sheet1.查詢

2.存檔仍然有疑惑 無存檔動作   
目錄裡沒此檔案 直接就存檔

3.如果條件改成 美國的話 (預設是台灣)  就沒辦法有存檔的動作出現
存二次 美國 看看
作者: mark15jill    時間: 2011-5-10 15:59

本帖最後由 mark15jill 於 2011-5-10 16:06 編輯

回復 7# GBKEE

1.兩個都沒內容+.+
Sub 按鈕5_Click()

End Sub
Sub 按鈕6_Click()

End Sub

2.已經解決無法存檔 和 無效問題QQ  謝謝您
剛剛把程式分開裝...
拆成兩部份丟去兩邊..

3.新增後的活頁簿名稱未改變.. 不過剛剛已經解決了..
原本是sheet1.  我多+了兩行..
   

        .Close 0
          Sheets("Sheet1").Select
         Sheets("Sheet1").Name = Sh.TextBox1


4.另外請問一下  
如果那樣的話 那是只要同一列的資料 不管有多少 都會列出來嗎??
因為我範例檔案只有到H欄位   實際上卻是到Z欄位0.0..

再次感謝您  :lol
作者: GBKEE    時間: 2011-5-10 16:39

回復 8# mark15jill
1.兩個都沒內容+.+     
沒有程式碼阿, 會有動作嗎?
3.新增後的活頁簿名稱未改變.. 不過剛剛已經解決了..
  1. Private Sub 存檔()
  2. Dim Sh As Object
  3. On Error Resume Next
  4. Set Sh = ThisWorkbook.Sheets(1)
  5. With Workbooks.Add(xlWBATWorksheet)
  6. Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]
  7. .Sheets(1).Name = Sh.TextBox1      '工作表名稱
  8. .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1
  9. .Close 0
  10. End With
  11. End Sub
複製代碼

4.因為我範例檔案只有到H欄位   實際上卻是到Z欄位0.0..
改紅字部位
.Offset(1).Resize(1,26) = Sh.Range(Sh.Cells(Rng.Row, "A"), Sh.Cells(Rng.Row, "Z")).Value
作者: mark15jill    時間: 2011-5-10 17:27

回復 9# GBKEE

1.當然沒動作XD!!    因為不知道要怎寫 所以 ... 不過現在已經解決了 謝謝
3.那個原始碼 是套用大大您的   可是 剛有試驗過 不能 不過後來有新增我列的兩行 就OK了...就是sheet1 變成 TEXT名稱  (不知道哪出錯-0-)
4.了解那行的意思了... 謝謝...
作者: GBKEE    時間: 2011-5-10 20:32

回復 10# mark15jill
3.那個原始碼 是套用大大您的   可是 剛有試驗過 不能 不過後來有新增我列的兩行 就OK了...就是sheet1 變成 TEXT名稱  (不知道哪出錯-0-)
可傳上完整程式碼看看??
作者: mark15jill    時間: 2011-5-11 08:05

這些是以大大的程式碼 加以延伸的..
  1. Sub 按鈕5_Click()
  2.     Dim Sh As Object

  4.     On Error Resume Next

  6.     Set Sh = ThisWorkbook.Sheets(1)

  8.    
  9.     With Workbooks.Add(xlWBATWorksheet)

  11.         Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]

  13.          .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1

  15.         .Close 0
  16.           Sheets("Sheet1").Select
  17.          Sheets("Sheet1").Name = Sh.TextBox1
  18.     End With

  20. End Sub
複製代碼
回復 11# GBKEE
作者: GBKEE    時間: 2011-5-11 09:26

回復 12# mark15jill
修改的程式,真的有達到你目地嗎?
Sub 按鈕5_Click()
    Dim Sh As Object
    On Error Resume Next      'On Error : 當程式執行時有錯誤時,   Resume Next : 繼續處裡下一個程式碼                                               
    Set Sh = ThisWorkbook.Sheets(1)
    With Workbooks.Add(xlWBATWorksheet)
        Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]
         .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1  
          'SaveAs: 當目錄中有相同的檔名 系統會詢問是否覆蓋原檔案  如選擇 [否] 或[取消] 都會產生錯誤值
          'On Error 就是在處裡這錯誤
        .Close 0                                 '如選擇 [否] 或[取消]: 檔案關閉且不存檔
         Sheets("Sheet1").Select   '檔案已關閉:請問這裡的 Sheets("Sheet1")是哪一個??
         Sheets("Sheet1").Name = Sh.TextBox1
    End With
End Sub
作者: mark15jill    時間: 2011-5-11 10:35

本帖最後由 mark15jill 於 2011-5-11 10:39 編輯

End Sub[/code]回復 13# GBKEE
剛剛發現 我那兩行位置有打錯= =....(應該是後來我又亂改 沒注意到 抱歉ˊˋ)
原始碼差別 已經附加檔案

以下是兩者的代碼

台灣的部份
Sub 按鈕5_Click()
    Dim Sh As Object

    On Error Resume Next

    Set Sh = ThisWorkbook.Sheets(1)

   
    With Workbooks.Add(xlWBATWorksheet)
          Sheets("sheet1").Select      
          Sheets("sheet1").Name = Sh.TextBox1 ' 新增的那個檔案內的名稱為 TEXT的字眼
          Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]

         .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1

        .Close 0

    End With

End Sub


美國的部份
Sub 按鈕5_Click()
    Dim Sh As Object

    On Error Resume Next

    Set Sh = ThisWorkbook.Sheets(1)

   
    With Workbooks.Add(xlWBATWorksheet)

        Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]

         .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1

        .Close 0
        ' Sheets("Sheet1").Select
        ' Sheets("Sheet1").Name = Sh.TextBox1
    End With

End Sub


附加檔案內有兩個 TXT 和 EXCEL檔案  分別為 美國和 台灣
[attach]6120[/attach]
作者: GBKEE    時間: 2011-5-11 11:42

回復 14# mark15jill
9樓程式碼中的 .Sheets(1).Name = Sh.TextBox1      '工作表名稱
        這紅點表示在所新增的活頁簿裡 不必再有   Sheets(1).Select
作者: mark15jill    時間: 2011-5-11 11:52

回復 15# GBKEE


    多謝指導><
習慣性都會多指定那個...



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