[發問] 如何從兩欄中尋找出指定值

luke

各位先進

sheet1表約有4000筆資料列(含空白列)
VBA是否可以篩選出兩欄中完全相同的值如附檔說明?

煩請大大 前輩指導
TEST27.rar (64.3 KB)

下載次數: 15

2013-4-27 18:18

lilytracy

回復 1# luke

若查首筆資料如下

1. Sub Test()
   
2. Dim Txt1 As String, Txt2 As String
   
3. Txt1 = [D3]
   
4. Txt2 = [E3]
   
5.   [D3] = IIf(Left(Txt1, 1) = ";", Mid(Txt1, 2, Len(Txt1) - 1), Txt1)
   
6.   [E3] = IIf(Left(Txt2, 1) = ";", Mid(Txt2, 2, Len(Txt2) - 1), Txt2)
   
7.     Cells.Find(What:=[D3], LookIn:=xlValues).Activate
   
8.      i = 1
   
9.       Do
   
10.        Cells.FindNext(After:=ActiveCell).Activate
    
11.         If Cells(ActiveCell.Row, 1).Value = [D3] And Cells(ActiveCell.Row, 2).Value = [E3] Then
    
12.          Exit Do
    
13.           ElseIf i > 4000 Then
    
14.           MsgBox "查無 " + [D3] + [E3] & "資料"
    
15.          Exit Do
    
16.         End If
    
17.       i = i + 1
    
18.     Loop
    
19. End Sub

複製代碼

GBKEE

回復 1# luke

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim R As Range, W As String, Rng As Range
   
4.     With ActiveSheet
   
5.         W = Application.Phonetic(.[D3:E3])       '結合兩字串
   
6.         For Each R In .Range("A:B").SpecialCells(xlCellTypeConstants).Rows '有資料的儲存格
   
7.             If W = Application.Phonetic(R) Then
   
8.                 If Rng Is Nothing Then
   
9.                     Set Rng = R
   
10.                 Else
    
11.                     Set Rng = Union(Rng, R)
    
12.                 End If
    
13.             End If
    
14.         Next
    
15.         If Rng Is Nothing Then
    
16.             MsgBox "查無 " & .[D3] & .[E3] & "資料"
    
17.         Else
    
18.             Rng.Select
    
19.             MsgBox "共 " & Rng.Cells.Count / 2 & "筆 資料"
    
20.         End If
    
21.     End With
    
22. End SubEnd Sub

複製代碼

luke

回復 3# GBKEE

謝謝超版答覆

    若sheet1表的A:B欄資料區是由兩個(或多個)文字檔匯入,  並有「END」檔尾區隔
    如果想跳過第1個有「END」 結尾, 來進行sheet1表D3和E3的查詢, 即D3輸入「DD」
    和E3輸入「Z1」  會先跳過第1個有「END」, 然後由下找到位於第2個資料區的
    【儲存格A45】而不是【儲存格A19】.
     
     同理: sheet1表D3輸入「BB」和E3輸入「X001」是否能往下跳  
    至第2個資料區的【儲存格A56】而不是【儲存格A32】

    以上是否可行?
    應如何修改VBA?
TEST27A.rar (30.21 KB)

下載次數: 5

2013-5-1 18:28

GBKEE

回復 5# luke

1. Private Sub Auto_open()   'Module1 於檔案開啟時自動執行的程式,要定義:"END"區塊位置
   
2.     'Names.Add 活頁簿中定義新名稱
   
3.         With sheet1.Range("A:A")
   
4.         If Not .Find("END", lookat:=xlWhole) Is Nothing Then
   
5.             .Replace "END", "=EX", xlWhole
   
6.             '將"END"替代為公式,因為無效的公式,儲存格傳回錯誤值
   
7.             With .SpecialCells(xlCellTypeFormulas, xlErrors)
   
8.                 Names.Add "資料區", RefersTo:=.Parent.Range(.Address)
   
9.                 .Value = "END"    '儲存格傳回錯誤值:回復原字串
   
10.             End With
    
11.             Names.Add "按鈕次數", 1           '按鈕1 第一個資料區
    
12.         Else
    
13.             Names.Add "按鈕次數", 0           '按鈕1
    
14.         End If
    
15.     End With
    
16. End Sub
    
17. Sub Ex()
    
18.     Dim i As Integer, W As String, Rng As Range
    
19.     If [按鈕次數] = 0 Then
    
20.         MsgBox "資料區 沒有 END區塊 "
    
21.         Exit Sub
    
22.     End If
    
23.     With ActiveSheet
    
24.         W = Application.Phonetic(.[D3:E3])       '結合兩字串
    
25.         'i = [資料區].Areas([按鈕次數]).Row       '第 i 個"END"資料區的列號
    
26.         For i = [資料區].Areas([按鈕次數]).Row To [資料區].Areas([資料區].Areas.Count).Row
    
27.             If W = Application.Phonetic(.Range("A:B").Rows(i)) Then
    
28.                 Names.Add "按鈕次數", [按鈕次數] + 1   '
    
29.                 Set Rng = .Range("A:B").Rows(i)
    
30.                 Exit For   '找到第一個 離開迴圈
    
31.             End If
    
32.         Next
    
33.         If Rng Is Nothing Then
    
34.             MsgBox "查無 " & .[D3] & .[E3] & "資料"
    
35.         Else
    
36.             Rng.Select
    
37.             MsgBox "找到 " & Rng.Cells(1, 1).Address(0, 0)
    
38.         End If
    
39.     End With
    
40.      If [資料區].Areas.Count = [按鈕次數] Then Names.Add "按鈕次數", 1     '[按鈕次數] 回到第一次
    
41. End Sub

複製代碼

luke

回復 7# GBKEE


    謝謝超版答覆

若sheet1表D3儲存格內容固定不變(不考慮E3儲存格), 如果想跳過第1個有「END」資料區,
然後由第2個資料區去查詢A:B欄中, 去做進階篩選(如圖片所示)出符合D3儲存格的全部資料.

例如:D3輸入「EEE」,從第2個資料區A欄
可找出第45列、第48列和第51列共有3列有「EEE」相同值如下:

第45列 EEE→Y01
第48列 EEE→Y04
第51列 EEE→Y02

如何修改VBA將A:B欄中的這些符合篩選資料複製至G:H欄?
TEST27B.rar (28.83 KB)

下載次數: 3

2013-5-2 10:52

下載 (147.99 KB)

2013-5-2 10:51

GBKEE

回復 6# luke
果想跳過第1個有「END」資料區
只有1個「END」資料區嗎??????
請將問題完整的提出來!!!

luke

回復 7# GBKEE


回復超版

以下是說明, 請參考附件{WORK結果}表所示結果

說明: 從[Sheet1表]A:C欄匯入文字檔可分為A型和B型.
[A型]
1.當匯入A型文字檔會有「END」(稱第1個資料區)及/或數量不等的資料區(稱第2個資料區、第3個資料區、第4資料區…餘此類推)如從Sheet1表A:C欄所示, 其中第1個資料區帶有空白資料列, 而第2個資料區以後, 每個資料區有數量不等資料列(但不含空白資料列). [Sheet1表]G:I欄是由D3儲存格(E3用Y*)為做查詢並先跳過「END」再行找出篩選結果. 例如:D3輸入「EEE」時會找出符合的Y01, Y04和Y02共3筆資料, 然後顯示結果(如G1:I3)於Sheet1表G:I欄(I欄有超連結功能).

2.[WORK表]是資料寫入工作表,其最後1列有1個「END」檔尾(上1列為空白資料列), [Sheet1表]的第1個資料區是以此「END」做複製目的. 當選取[Sheet1表]的第1個資料區後再複製至[WORK表]並覆蓋「END」貼上. 若A型文字檔還有其他的資料區就要做相互尋找與插入(複製貼上)功能; 並利用上述篩選結果, 由[WORK表] G:H欄開始先找出G1和H1內容如G1=「EEE」和H1=「Y01」(本例如第1點說明)進行[Sheet1表]的第2個資料區(如A13:C14)做複製, 然後切換至[WORK表]去找到符合[Sheet1表] G1=「EEE」和H1=「Y01」的位址, 將[Sheet1表]的第2個資料區插入此位址(如[WORK表]所示結果).

同理:
繼續做下個G2=「EEE」和H2=「Y04」並將[Sheet1表] 的第3個資料區(如A16:C17)做複製並插入至[WORK表]符合[Sheet1表] G2=「EEE」和H2=「Y04」的位址. 然後繼續做下個G3=「EEE」和H3=「Y02」並將[Sheet1表] 的第4個資料區(如A19:C21)做複製並插入至[WORK表]符合[Sheet1表] G3=「EEE」和H3=「Y02」的位址…餘此類推

[B型]
當匯入B型文字檔至[Sheet1表]A:C欄(範例顯示於L: M欄)就會有「MMM」做檔尾, 但不會有「END」,其資料是以[Sheet1表]D3和E3來做[WORK表]刪除功能. 若D3輸入「EEE」和E3輸入「Y15」,就會進行[WORK表]符合D3:「EEE」和E3:「Y15」查詢, 找到此筆資料(僅1筆)的地址後,往上選取[WORK表]A:C欄區塊資料列並做該區塊資料列刪除工作, 然後將B型文字檔的[Sheet1表]資料全部選取(如L3:N8)並插入貼至[WORK表]該處(如C34)即完成.

應如何修改VBA達到這樣的結果?
TEST27B.rar (104.77 KB)

下載次數: 8

2013-5-3 23:11

GBKEE

回復 8# luke
不好意思,看了兩天,你說的很詳細但還是看不懂
可以附上檔案的4個工作表內容是
1 [SHEET1 A]工作表是  文字檔A型
2 [SHEET1 B]工作表是  文字檔B型
3 [A WORK]工作表是 :  文字檔A型 貼上[A WORK]工作表 後 執行 複製 插入 的範例
4 [B WORK]工作表是 :   文字檔B型 貼上[A WORK]工作表 後 執行 刪除 插入 的範例

luke

回復 9# GBKEE


    回覆超版

    1.[Sheet1表]插入資料至[WORK表]有4個資料區
        A1:C10
        A13:C16
        A18:C21
        A23:C27
2.執行「寫入WORK」按鍵時因[WORK表]有部份資料列與[Sheet1表]重覆就會產生錯誤, 若[WORK表]改copy方式, 直接複製[Sheet1表]的4個資料區至[WORK表]

If D.EXISTS(A.Cells(1, 1) & A.Cells(1, 2)) Then
D(A.Cells(1, 1) & A.Cells(1, 2)).Copy
With A.Resize(1, D(A.Cells(1, 1) & A.Cells(1, 2)).Columns.Count)
.Insert Shift:=xlDown
End With
End If

應如何修改 上述VBA語法?

以上
TEST27D.rar (37.33 KB)

下載次數: 6

2013-5-29 06:04