[發問] 請教多項目比對，篩選

lusyfatw

各位前輩好，請教多項目比對，篩選

平時操作皆利用函數較多，vba之運用僅略懂皮毛
皆利用討論版內各主題資料(基礎部份)，自己在反覆測試來達到需求。
但搜尋討論版許久，實在無頭緒，故發帖向前輩們請教，感謝各位。

附件工作表data的檢測項目需小於工作表spc各規格的檢測項目，
符合便將data內該列資料複製到符合規格之工作表


test.zip (22.12 KB)

下載次數: 12

2018-11-4 11:02

faye59

回復 1# lusyfatw


    我幫忙整理一下規則
DATA資料讀取檢測項目1-13?
讀取完比對spc項目1-13?
依序由上到下比對符合的參數?
符合的填入該A欄位名稱對應的活頁簿?
填入後該筆DATA中的資料是否移除?保留?
如果保留，當重覆執行第二次對應的貨頁簿中已存在檔案是否覆蓋?往下貼入?
如果spc A欄位中有未建立的活頁簿是否跳過?新增A欄名稱活頁簿?

清楚的邏輯及流程才有辦法幫上忙。

lusyfatw

回復 2# faye59

DATA資料讀取檢測項目1-13?   是的
讀取完比對spc項目1-13?         有檢測值的項目
依序由上到下比對符合的參數?        是的
符合的填入該A欄位名稱對應的活頁簿?       是的
填入後該筆DATA中的資料是否移除?保留?     保留
如果保留，當重覆執行第二次對應的貨頁簿中已存在檔案是否覆蓋?往下貼入?   往下貼入
如果spc A欄位中有未建立的活頁簿是否跳過?新增A欄名稱活頁簿?    這部份會先建好，就沒有此想法

lusyfatw

回復 2# faye59

小弟只會皮毛，利用一個一個比對，還請網兄賜教，謝謝您。

t1.zip (72.29 KB)

下載次數: 9

2018-11-5 01:14

Sub test()

Dim a, b, c, d, e, f, g

Set s1 = Worksheets("spc")
Set d1 = Worksheets("DATA")
Set d2 = Worksheets("OEM-7IMP-2Y-01")

a = s1.Range("B2")
b = s1.Range("C2")
c = s1.Range("D2")
d = s1.Range("E2")
e = s1.Range("F2")
f = s1.Range("G2")
g = s1.Range("H2")

For i = 2 To 150
If (d1.Range("N" & i) <= a) * (d1.Range("O" & i) <= b) * (d1.Range("P" & i) <= c) * (d1.Range("Q" & i) <= d) * (d1.Range("R" & i) <= e) * (d1.Range("S" & i) <= f) * (d1.Range("T" & i) <= g) Then
d1.Range("b" & i & ":Z" & i).Copy
Worksheets("OEM-7IMP-2Y-01").Activate
d2.Range("B1048576").Select
Selection.End(xlUp).Select
d2.Range("b" & ActiveCell.Row + 1).PasteSpecial Paste:=xlPasteValues
End If
Next

End Sub

n7822123

回復 4# lusyfatw


你的SPC 分頁有些檢測項目是空白的，

如果用0去卡，那就不會有合規格的批號，

你的程式也只有比7項，8~13項都不用管嗎!?

n7822123

回復 5# n7822123

空白的部分我就當做不卡規格，判斷為PASS!

Sub Ex()
Dim 合格 As Boolean
Dim R%, Ri%, i%, Rn%, sh%, Spcs, Arr
Arr = Range([spc!N2], [spc!A2].End(xlDown))
Set Shs = Sheets("spc")
Spcs = Shs.[A2].End(xlDown).Row - 1
Sheets("DATA").Activate
Rn = [A1].End(xlDown).Row
For sh = 1 To Spcs
  With Sheets(Arr(sh, 1))
    Debug.Print .Name
    .Cells(2, 2).Resize(Rn, 25).ClearContents
    Ri = 2
    For R = 2 To Rn
      合格 = True
      For i = 1 To 13
        If Arr(sh, i + 1) <> "" And Cells(R, i + 12) > Arr(sh, i + 1) Then 合格 = False: Exit For
      Next i
      If 合格 Then .Cells(Ri, 2).Resize(, 25) = Cells(R, 1).Resize(, 25).Value: Ri = Ri + 1
    Next R
  End With
Next sh
End Sub