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

標題: [發問] 在同一列同時比對兩欄資料方法 [打印本頁]

作者: 假面超人 時間: 2012-8-1 23:01 標題: 在同一列同時比對兩欄資料方法

各位先進，小弟因工作需要要用excel 做一些資料的處理，目前遇到些問題，希望各位先進能幫我解惑

品號    名稱    製程工序工時
123    剪刀    下料    1    100
123    剪刀    粗胚    2    200
123    剪刀    研磨    3    100
124    叉子    下料    1    100

資料結構大概是這樣，我想同時蒐尋當品號123、工序是1，這筆資料列的位置，因為我想把相對應之工時這欄位資料擷取出來，麻煩各位先進了~謝謝

作者: Hsieh 時間: 2012-8-1 23:32

回復 1# 假面超人
進階篩選即可
[attach]11991[/attach]

作者: 假面超人 時間: 2012-8-1 23:46

回復 2# Hsieh

抱歉!不知是否有範例檔案，影片看不太清處詳細內容

作者: 假面超人 時間: 2012-8-2 00:24

原來按下去就可以放大，謝謝您
不知道是否還有其他方法?因為資料幾萬筆，欄位數也很多
我主要是想知道該列的位置，然後擷取某幾個欄位的資料填到別的欄位上

作者: smouse0220 時間: 2012-8-2 01:56

品號名稱製程工時
123 剪刀下料 1 100
123 剪刀粗胚 2 200
123 剪刀研磨 3 100
124 叉子下料 1 100

複製代碼

假設你的資料是如上述的方式排列(也就是 "品號"在A1 , "名稱"在B1 , "123"在A2..以此類推)
我會用以下的方式節選出來
PS:把資料放在Sheet1 , 多開一個sheet2(資料會轉存到這)

Sub Trans()
Dim New_Count,Data_Count,I as Double
Dim Key_Word1 as string
Dim Key_Word2 as string
worksheets(2).range("A1").value="品號"
worksheets(2).range("B1").value="工序"
Data_Count=worksheets(1).range("A65536").end(xlup).row
For I = 1 to Data_Count
Key_Word1=worksheets(1).range("A" & I).value '品號
Key_Word2=worksheets(1).range("D" & I).value '工序
If Key_Word1="123" and Key_Word1="1" Then
New_Count=worksheets(2).range("A65536").end(xlup).row
worksheets(2).range("A" & New_Count+1).value=Key_Word1
worksheets(2).range("B" & New_Count+1).value=Key_Word2
End IF
Next I
end sub

複製代碼

作者: GBKEE 時間: 2012-8-2 07:01

我主要是想知道該列的位置，然後擷取某幾個欄位的資料填到別的欄位上假面超人發表於 2012/8/2 00:24

上傳檔案來看看

作者: 假面超人 時間: 2012-8-2 13:31

回復 5# smouse0220

真的太謝謝你了，這樣讓又能繼續寫下去了!

第15列中的 If Key_Word1="123" and Key_Word1="1" Then
好像有點問題，我修改成 If Key_Word1="123" and Key_Word2="2" Then
就能正常判斷了

作者: 假面超人 時間: 2012-8-2 14:39

剛試了一下，還是不行
我想要做的是
當判斷品號和工序是在同一列時
去抓在同一列裡面工時這個資料

原本只用vlooKup 去判斷和抓資料，但他只能判斷單一的資料
當遇到多筆重複的資料時只會去抓最先找的那一筆
摸索了好久
才想到VBA或許能解決這問題
請個位先進指點一下!!謝謝

作者: 假面超人 時間: 2012-8-2 15:22

回復 6# GBKEE

[attach]11994[/attach]

這只是類似要處理的檔案
檔案來源是
第一個工作頁的品號欄由BOM表展開，後面的名稱、製程等都是後來要從其他工作頁抓過來填入
後面工作頁是由現場單位實際情況生產情況回報回來

目前要處理的動作
第一個工作頁的品號欄都是獨立不會重複，但其他工作頁的品號會重複(因為資料來源就是這樣)，所以我才會想既然裡面有工序，就以工序做第二判斷條件去抓取同一列裡面如工時等其他資料回寫到工作頁1裡面，如果有三個相同品號但工序不同的資料，會依照工序順序在下面又新增兩列，再把資料抓進來(這部分目前寫道變成無窮迴圈，還在動腦中)

作者: Hsieh 時間: 2012-8-2 16:21

回復 9# 假面超人

進階篩選很容易達成
[attach]11995[/attach]
如果堅持寫迴圈

Sub ex()
Dim Ar()
With Sheet1
For Each a In .Range(.[A2], .[A2].End(xlDown))
With Sheet2
For Each b In .Range(.[A2], .[A2].End(xlDown))
If b = a Then
ReDim Preserve Ar(s)
Ar(s) = Array(b.Value, b.Offset(, 1).Value, b.Offset(, 2).Value, b.Offset(, 4).Value)
s = s + 1
End If
Next
End With
Sheet3.[A65536].End(xlUp).Offset(1).Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
Erase Ar
s = 0
Next
End With
End Sub

複製代碼

作者: GBKEE 時間: 2012-8-2 17:00

回復 9# 假面超人
依據你的檔案寫下進階篩選的程式

Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range
Set Rng(1) = Sheet1.Range("a1").CurrentRegion '進階篩選: 準則範圍取得為 Sheet1[A1:A3]
Set Rng(2) = Sheets("最終結果").Range("A1").CurrentRegion
Rng(2) = "" '清理先前篩選的資料
Rng(1).Rows(1).Copy Rng(2).Cells(1) '複製準則的欄位
'試試看將上一行程式碼註解不執行看看
'進階篩選 : 複製到目的範圍第1列有那些資料庫的欄位就顯示那些資料
'如空白會顯示全部欄位的資料
Sheet2.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).CurrentRegion
End Sub

複製代碼

作者: smouse0220 時間: 2012-8-2 19:32

回復 smouse0220

真的太謝謝你了，這樣讓又能繼續寫下去了!

第15列中的 ...
假面超人發表於 2012-8-2 13:31

[attach]11996[/attach]

作者: 假面超人 時間: 2012-8-2 19:35

回復 11# GBKEE

追加問一個問題
如果要搜尋123,124兩筆資料
123的資料在工作頁2裡可找到
124的資料在工作頁3裡可找到

我用您的程式碼修改

For a = 2 To 3
Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).CurrentRegion
Next

複製代碼

加了這迴圈，這樣他兩筆資料都會找到，可是當第2次找到時就會把第1次找到的資料蓋掉，是否可以讓第二2找到的資料在第1次的資料之下以此類推

作者: 假面超人 時間: 2012-8-2 19:40

回復 12# smouse0220

sorry...
我的等級不足，無法下載檔案，是否方便上傳到免空
http://imxd.net/

作者: smouse0220 時間: 2012-8-2 20:38

回復 14# 假面超人

Fyi.
http://imxd.net/file?id=6716

作者: GBKEE 時間: 2012-8-2 20:46

回復 13# 假面超人

Option Explicit
Sub Ex() '有多於2個以上的工作表要篩選
Dim Rng(1 To 3) As Range, a As Integer, Sh_Count As Integer
Sh_Count = Sheets.Count '此活頁簿中工作表的總數
Set Rng(1) = Sheets(1).Range("a1").CurrentRegion '進階篩選: 準則範圍取得為 Sheet1[A1:A3]
'Set Rng(2) = Sheets("最終結果").Range("A1").CurrentRegion '改為此活頁簿中最後的工作表
Set Rng(2) = Sheets(Sh_Count).Range("A1").CurrentRegion
Rng(2) = "" '清理先前篩選的資料
Rng(1).Rows(1).Copy Rng(2).Cells(1) '複製準則的欄位
For a = 2 To Sheets.Count - 1
Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
Set Rng(2) = Rng(2).Cells(1).End(xlDown).Offset(1) '複製到目的範圍往下移動
If a <> Sheets.Count - 1 Then Rng(1).Rows(1).Copy Rng(2).Cells(1)
If Rng(3) Is Nothing Then '紀錄複製第2個工作表以後的複製到目的範圍欄位第一列位置
Set Rng(3) = Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
Else
Set Rng(3) = Union(Rng(3), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count))
End If
Next
If Not Rng(3) Is Nothing Then Rng(3).Delete xlUp '刪除紀錄複製第2個工作表以後的複製到目的範圍欄位第一列位置
End Sub

複製代碼

作者: 假面超人 時間: 2012-8-2 21:26

回復 16# GBKEE

GBKEE版大一直麻煩你真的不好意思
針對您寫的那程式做了測試大致上沒問題
但有點小問題
搜尋到最後的排序會依照先在哪個分頁找到的寫入到最後會亂掉，是否可以能讓資料順序和工作頁1一樣?謝謝
[attach]11997[/attach]

作者: c_c_lai 時間: 2012-8-2 21:29

回復 16# GBKEE
請教：
Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
是不是要修改成：
Sheets(2).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
否則下一個工作表單如為空白，則會有錯誤訊息。

作者: c_c_lai 時間: 2012-8-2 22:29

回復 16# GBKEE
看了#17樓的範例，霍然大悟。因為範例中沒有空白表單之故。

作者: Hsieh 時間: 2012-8-2 22:38

本帖最後由 Hsieh 於 2012-8-6 18:48 編輯

回復 17# 假面超人
是要照Sheet1的排序嗎?

Sub nn()
Dim Ar(), A As Range, B As Range
With Sheets("Sheet1")
For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp)) 第一頁A2以下做迴圈
For Each Sh In Sheets(Array("Sheet2", "Sheet3")) '原資料所在工作表
With Sh
For Each B In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp)) '在A2以下儲存格做迴圈
If B = A Then '跟第一頁A欄儲存格做比對，如果符合
ReDim Preserve Ar(s) '擴大陣列
Ar(s) = Array(B.Value, B.Offset(, 1).Value, B.Offset(, 2).Value, B.Offset(, 4).Value) '將值寫入陣列
s = s + 1 '準備下一次擴大陣列
End If
Next
End With
Next
With Sheets("最終結果")
If s > 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(s, 4).Value = Application.Transpose(Application.Transpose(Ar)) '如果陣列有寫入，就將陣列寫入結果
Erase Ar: s = 0 '清空陣列，並準備下一個陣列初始大小
End With
Next
End With
End Sub

複製代碼

作者: 假面超人 時間: 2012-8-2 22:46

回復 20# Hsieh

太謝謝Hsieh版大!!這是我想要的結果~
也謝謝smouse0220和GBKEE兩位..
在颱風假中還要動腦~
腦細胞應該死了不少...
萬分感謝

作者: 假面超人 時間: 2012-8-6 16:51

回復 20# Hsieh

版大想請教一下，目前找不到資料是忽略掉(在最後一頁上找不到任何的資料)，是否可以改成找不到資料是否還是可以顯示第一頁的品號，其它欄位顯示"空白"或是"查無資料"?

作者: 假面超人 時間: 2012-8-6 17:37

回復 20# Hsieh

順便想請教，在第17列的位置用了IF但是為什麼下面不用END IF做結束
而18列的程式碼又是代表什麼意思呢?

作者: Hsieh 時間: 2012-8-6 22:34

本帖最後由 Hsieh 於 2012-8-6 22:38 編輯

回復 23# 假面超人

Sub nn()
Dim Ar(), A As Range, B As Range
With Sheets("Sheet1")
For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp)) '第一頁A2以下做迴圈
For Each Sh In Sheets(Array("Sheet2", "Sheet3")) '原資料所在工作表
With Sh
For Each B In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp)) '在A2以下儲存格做迴圈
If B = A Then '跟第一頁A欄儲存格做比對，如果符合
ReDim Preserve Ar(s) '擴大陣列
Ar(s) = Array(B.Value, B.Offset(, 1).Value, B.Offset(, 2).Value, B.Offset(, 4).Value) '將值寫入陣列
s = s + 1 '準備下一次擴大陣列
End If
Next
End With
Next
With Sheets("最終結果")
If s > 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(s, 4).Value = Application.Transpose(Application.Transpose(Ar)) Else _
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4).Value =Array(A.value,"","","") '如果陣列有內容，就將陣列寫入結果，否則寫入一列空白
Erase Ar: s = 0 '清空陣列，並準備下一個陣列初始大小
End With
Next
End With
End Sub

複製代碼

17列的If陳述式，因為If...Then...在同一行所以不須End If詳細語法請參考VBA說明

作者: 假面超人 時間: 2012-8-6 23:09

回復 24# Hsieh
原來還有這樣用法，我沒看過...
謝謝您~~
還在努力學習中!!

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