返回列表 上一主題 發帖

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

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

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

資料比較.zip (1.78 KB)

回復 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
複製代碼
學海無涯_不恥下問

TOP

回復 2# Hsieh


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

TOP

回復 2# Hsieh


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

TOP

回復 4# jcchiang
  1. Sub ex()

  2. Dim Rng As Range, a, b As Range, c 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 = Nothing
  9.     For Each b In .Range(.[A2], .[A65536].End(xlUp))
  10.         If b = a Then
  11.            If c Is Nothing Then
  12.            Set c = b.MergeArea.Resize(, 6)
  13.            Else
  14.            Set c = Union(c, b.MergeArea.Resize(, 6))
  15.            End If
  16.         End If
  17.     Next
  18.      If Not c Is Nothing Then
  19.         If Rng Is Nothing Then
  20.            Set Rng = c
  21.         Else
  22.            Set Rng = Union(Rng, c)
  23.         End If
  24.      End If
  25.   End With
  26.   r = r + 1
  27.   Loop
  28. End With
  29. With Sheet3
  30.   .UsedRange.Offset(1).Clear
  31.   Rng.Copy .[A2]
  32. End With
  33. End Sub
複製代碼
學海無涯_不恥下問

TOP

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

TOP

jcchiang  大大

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

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

麻煩解惑

TOP

回復 7# ADS0126


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

TOP

本帖最後由 GBKEE 於 2015-5-27 19:40 編輯

回復 7# ADS0126
With Sheet2  <-你缺少的物件
  r = 2
  Do Until .Cells(r, 1) = ""   這.點 是物件的屬性,方法,子物件。
  a = .Cells(r, 1)
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

jcchiang 大大

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

TOP

        靜思自在 : 一個人不怕錯,就怕不改過,改過並不難。
返回列表 上一主題