麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 資料比較後截出所需資料 [打印本頁]

作者: jcchiang 時間: 2013-2-4 10:50 標題: 資料比較後截出所需資料

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

[attach]14133[/attach]

作者: Hsieh 時間: 2013-2-4 11:15

回復 1# jcchiang

Sub ex()
Dim Rng As Range
With Sheet2
r = 2
Do Until .Cells(r, 1) = ""
a = .Cells(r, 1)
With Sheet1
Set c = .Columns("A").Find(a, lookat:=xlWhole)
If Not c Is Nothing Then
Set c = c.MergeArea.Resize(, 6)
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

複製代碼

作者: jcchiang 時間: 2013-2-4 11:36

回復 2# Hsieh

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

作者: jcchiang 時間: 2013-2-4 13:26

回復 2# Hsieh

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

作者: Hsieh 時間: 2013-2-4 15:43

回復 4# jcchiang

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)
With Sheet1
Set c = Nothing
For Each b In .Range(.[A2], .[A65536].End(xlUp))
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
Next
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

複製代碼

作者: jcchiang 時間: 2013-2-4 16:06

回復 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 時間: 2015-5-15 22:19

jcchiang 大大

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

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

麻煩解惑

作者: jcchiang 時間: 2015-5-26 16:19

回復 7# ADS0126

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

作者: GBKEE 時間: 2015-5-27 15:22

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

回復 7# ADS0126

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

作者: ADS0126 時間: 2015-5-28 23:33

jcchiang 大大

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

作者: ADS0126 時間: 2015-5-28 23:46

回復 9# GBKEE

GBKEE 大大
感謝回覆
剛踏入VBA程式
很多語法還在努力學習中...^^
非常感謝

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