[發問] 多筆EXCEL搜尋的用法[已解決 2011-05-11]

mark15jill

如題..
因資料數很多，想說用一個EXCEL VBA 將其關鍵字搜尋出來 並且 另存一份新的EXCEL檔案
如附檔...
能.rar (28.27 KB)

下載次數: 12

2011-5-10 10:26

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

mark15jill

回復 15# GBKEE


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

GBKEE

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

mark15jill

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檔案  分別為 美國和 台灣
查詢比對.rar (10.14 KB)

下載次數: 12

2011-5-11 10:35

GBKEE

回復 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

這些是以大大的程式碼 加以延伸的..

1. Sub 按鈕5_Click()
   
2.     Dim Sh As Object
   
3. 
   
4.     On Error Resume Next
   
5. 
   
6.     Set Sh = ThisWorkbook.Sheets(1)
   
7. 
   
8.    
   
9.     With Workbooks.Add(xlWBATWorksheet)
   
10. 
    
11.         Sh.UsedRange.Offset(1).Copy .Sheets(1).[A1]
    
12. 
    
13.          .SaveAs ThisWorkbook.Path & "\" & Sh.TextBox1
    
14. 
    
15.         .Close 0
    
16.           Sheets("Sheet1").Select
    
17.          Sheets("Sheet1").Name = Sh.TextBox1
    
18.     End With
    
19. 
    
20. End Sub

複製代碼

回復 11# GBKEE

GBKEE

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

mark15jill

回復 9# GBKEE

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

GBKEE

回復 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

回復 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