[發問] 資料比較後截出所需資料

jcchiang

在(資料Sheet)內比對有無(抓取Item Sheet)內相同的名稱後,
將相同資料移至(結果Sheet),請問要如何使用VB執行

資料比較.zip (1.78 KB)

下載次數: 23

2013-2-4 10:48

Hsieh

回復 1# jcchiang

1.     Sub ex()
   
2. Dim Rng As Range
   
3. With Sheet2
   
4.   r = 2
   
5.   Do Until .Cells(r, 1) = ""
   
6.   a = .Cells(r, 1)
   
7.   With Sheet1
   
8.      Set c = .Columns("A").Find(a, lookat:=xlWhole)
   
9.      If Not c Is Nothing Then
   
10.      Set c = c.MergeArea.Resize(, 6)
    
11.         If Rng Is Nothing Then
    
12.            Set Rng = c
    
13.         Else
    
14.            Set Rng = Union(Rng, c)
    
15.         End If
    
16.      End If
    
17.   End With
    
18.   r = r + 1
    
19.   Loop
    
20. End With
    
21. With Sheet3
    
22.   .UsedRange.Offset(1).Clear
    
23.   Rng.Copy .[A2]
    
24. End With
    
25. End Sub

複製代碼

jcchiang

回復 2# Hsieh


    問題已解決,感謝版主的指導

jcchiang

回復 2# Hsieh


    還有一個問題再後續測試時發現
       當(資料Sheet)內,同時有比對的Item是相同的(同時有兩個a),但只會抓到第一筆
       嘗試修正仍無法成功抓出,請問要如何修改,謝謝

Hsieh

回復 4# jcchiang

1. Sub ex()
   
2. 
   
3. Dim Rng As Range, a, b As Range, c As Range
   
4. 
   
5. With Sheet2
   
6.   r = 2
   
7.   Do Until .Cells(r, 1) = ""
   
8.   a = .Cells(r, 1)
   
9.   With Sheet1
   
10.   Set c = Nothing
    
11.     For Each b In .Range(.[A2], .[A65536].End(xlUp))
    
12.         If b = a Then
    
13.            If c Is Nothing Then
    
14.            Set c = b.MergeArea.Resize(, 6)
    
15.            Else
    
16.            Set c = Union(c, b.MergeArea.Resize(, 6))
    
17.            End If
    
18.         End If
    
19.     Next
    
20.      If Not c Is Nothing Then
    
21.         If Rng Is Nothing Then
    
22.            Set Rng = c
    
23.         Else
    
24.            Set Rng = Union(Rng, c)
    
25.         End If
    
26.      End If
    
27.   End With
    
28.   r = r + 1
    
29.   Loop
    
30. End With
    
31. With Sheet3
    
32.   .UsedRange.Offset(1).Clear
    
33.   Rng.Copy .[A2]
    
34. End With
    
35. End Sub

複製代碼

jcchiang

回復 5# Hsieh

    驗證後已解決相同Item只能抓到一筆的問題
    參考版主的程式,將For..Next改用Do while..loop也能得到一樣的效果
       感謝版主的指導
Sub ex()

Dim Rng As Range, a, b As Range, c As Range

With Sheet2
  r = 2
  Do Until .Cells(r, 1) = ""
  a = .Cells(r, 1)
  Set b = Sheet1.Range("A2")
  With Sheet1
  Set c = Nothing
    Do While b <> ""
        If b = a Then
           If c Is Nothing Then
           Set c = b.MergeArea.Resize(, 6)
           Else
           Set c = Union(c, b.MergeArea.Resize(, 6))
           End If
        End If
        Set b = b.Offset(1)
    Loop
     If Not c Is Nothing Then
        If Rng Is Nothing Then
           Set Rng = c
        Else
           Set Rng = Union(Rng, c)
        End If
     End If
  End With
  r = r + 1
  Loop
End With
With Sheet3
  .UsedRange.Offset(1).Clear
  Rng.Copy .[A2]
End With
End Sub

ADS0126

jcchiang  大大

因為權限不夠無法下載原始檔
只能自己試試看
看到這個主題很符合
目前工作上的需求
只是有個小問題???

Do Until .Cells(r, 1) = ""  <------程式跑到此段會出現"需要物件"

麻煩解惑

jcchiang

回復 7# ADS0126


Do Until .Cells(r, 1) = ""
這個位置是放要被比較的項目
EX:如果你要在資料內搜索"Test"相關的資料
     那Cells(r,1)的位置就放入"Test"
     因為我要比較很多資料所以 "r" 為變數

GBKEE

回復 7# ADS0126

With Sheet2  <-你缺少的物件
  r = 2
  Do Until .Cells(r, 1) = ""   這.點 是物件的屬性,方法，子物件。
  a = .Cells(r, 1)

ADS0126

jcchiang 大大

原來是這樣...筆記中....