aa7551

回復 10# yanto913
條件說的不清楚,抱歉
一.成品如a,b項,在第九碼各為L,R(其餘均為相同)視為相同,只需選a項,其餘符合第二項均選
三.零件如f,g項在為12碼各為L,R(其餘均為相同)視為相同,只需選f項目,其餘符合第四項均選

yanto913

改成不等於"R"

stillfish00

回復 11# aa7551
這樣判斷你看結果符不符合

1. Sub test()
   
2. Dim ar, s, ss, d1, d2
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. 
   
6. With Sheets(1)
   
7.     ar = .Range(.[a2], .[a2].End(xlDown)).Value
   
8.     For Each s In ar
   
9.         '成品
   
10.         If s Like "???-????L*" Then
    
11.             d1.Item(s) = ""
    
12.             ss = Left(s, 8) & "R" & Mid(s, 10)
    
13.             If d1.exists(ss) Then d1.Remove (ss)
    
14.         End If
    
15.         If s Like "???-????R*" Then '非成對保留
    
16.             If Not d1.exists(Left(s, 8) & "L" & Mid(s, 10)) Then d1.Item(s) = ""
    
17.         End If
    
18.         
    
19.         '零件
    
20.         If s Like "??????-????L*" Then
    
21.             d2.Item(s) = ""
    
22.             ss = Left(s, 11) & "R" & Mid(s, 13)
    
23.             If d2.exists(ss) Then d2.Remove (ss)
    
24.         End If
    
25.         If s Like "??????-????R*" Then '非成對保留
    
26.             If Not d2.exists(Left(s, 11) & "L" & Mid(s, 13)) Then d2.Item(s) = ""
    
27.         End If
    
28.     Next
    
29.     .[k2].Resize(d1.Count) = Application.Transpose(d1.keys)
    
30.     .[n2].Resize(d2.Count) = Application.Transpose(d2.keys)
    
31. End With
    
32. Set d1 = Nothing: Set d2 = Nothing
    
33. End Sub

複製代碼

aa7551

回復 13# stillfish00
115-1926L-A
132-1905L-LD-U
211-1946L-A
211-1946L-A-S        這些不符合條件,成品的第五,六碼要等於11,17,20,25,37

Hsieh

回復 9# aa7551

規則如果能確定，用進階篩選也是不錯的方法

    進階篩選.rar (131.14 KB)

下載次數: 9

2013-1-18 23:26

aa7551

回復 12# yanto913
謝謝大大的指教,我先說明自己的手動作法,先把LR配對放在一起,確認有配對,再檢查是否符合成品11,20或零件11,17,20,25,37,如有符合,則刪去R

aa7551

回復 15# Hsieh
謝謝大大指教,提供一個新方式

aa7551

筆者作業模式是逐筆刪除:
一.成品第五,六碼是否符合11,17,20,25,37,如不符合即刪除,再將第九碼是L,R配對(其餘碼是相同者,如112-1104L-LD,112-1104R-LD)放在一起,配對成功,刪去R(112-1104R-LD),如無配對,則保留
二.零件第八,九碼是否符合11,20,如不符合即刪除,再將第十二碼是L,R配對(其餘碼是相同者,如00#440-1126LEND,00#440-1126REND)放在一起,配對成功,刪去R(00#440-1126REND),如無配對,則保留

stillfish00

回復 18# aa7551

1. Sub test()
   
2. Dim ar, s5s6, s8s9, s, d1, d2
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. 
   
6. With Sheets(1)
   
7.     ar = .Range(.[a2], .[a2].End(xlDown)).Value
   
8.     For Each s In ar
   
9.         s5s6 = Mid(s, 5, 2)
   
10.         If Mid(s, 4, 1) = "-" And (s5s6 = "11" Or s5s6 = "17" Or s5s6 = "20" Or s5s6 = "25" Or s5s6 = "37") Then d1.Item(s) = ""
    
11.             
    
12.         s8s9 = Mid(s, 8, 2)
    
13.         If Mid(s, 7, 1) = "-" And (s8s9 = "11" Or s8s9 = "20") Then d2.Item(s) = ""
    
14.     Next
    
15.     For Each s In d1.keys
    
16.         If Mid(s, 9, 1) = "R" And d1.exists(Left(s, 8) & "L" & Mid(s, 10)) Then
    
17.             d1.Remove (s)
    
18.         End If
    
19.     Next
    
20.     For Each s In d2.keys
    
21.         If Mid(s, 12, 1) = "R" And d2.exists(Left(s, 11) & "L" & Mid(s, 13)) Then
    
22.             d2.Remove (s)
    
23.         End If
    
24.     Next
    
25.    
    
26.     .[k2].Resize(d1.Count) = Application.Transpose(d1.keys)
    
27.     .[n2].Resize(d2.Count) = Application.Transpose(d2.keys)
    
28. End With
    
29. Set d1 = Nothing: Set d2 = Nothing
    
30. End Sub

複製代碼

aa7551

回復 19# stillfish00
謝謝大大指教,應是正確解答