starry1314

回復 10# 准提部林


   
Sub TEST()
Dim xArea As Range, xR As Range, xU As Range, xD, T$, i&
For i = 1 To 9 Step 4 '請問這個9的意思是?  知道後面的4是 總共一組四欄來刪除
　　Set xD = CreateObject("Scripting.Dictionary")
　　Set xArea = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp)(1, 4))
　　For Each xR In xArea
　　　　T = xR(1, 2) & xR(1, 3): xD(T) = xD(T) + 1
　　Next
　
　　Set xU = Cells(xArea.Rows.Count + 2, 1)
　　For Each xR In xArea
　　　　T = xR(1, 2) & xR(1, 3)
　　　　If xD(T) >= 20 And xR(1, 4) = "." Then Set xU = Union(xU, xR.Resize(1, 4))
　　Next
　
　　If xU.Count > 1 Then xU.Delete Shift:=xlUp
Next i
End Sub

starry1314

回復 10# 准提部林

版大~不好意思 現欄位有增加，試過後改不太出來  
只會刪除部份資料 第一表格會全刪,第二、三表格只會刪除部份資料
    多條件判斷刪除-2.rar (92.51 KB)

下載次數: 3

2015-11-28 09:37

starry1314

回復 10# 准提部林
目前改為這樣可達成效果,不知是否有不妥的地方
Sub 標籤()
Dim xArea As Range, xR As Range, xU As Range, xD, T$, i&
For i = 1 To 28 Step 9
    Set xD = CreateObject("Scripting.Dictionary")
    Set xArea = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp)(1, 8))
    For Each xR In xArea
        T = xR(1, 5) & xR(1, 6): xD(T) = xD(T) + 1
    Next

    Set xU = Cells(xArea.Rows.Count + 2, 1)
    For Each xR In xArea
        T = xR(1, 5) & xR(1, 6)
        If xD(T) >= 20 And xR(1, 8) = "." Then Set xU = Union(xU, xR.Resize(1, 9))
    Next

    If xU.Count > 1 Then xU.Delete Shift:=xlUp
Next i
End Sub

准提部林

回復 13# starry1314


Set xArea = Range(Cells(2, i), Cells(Rows.Count, i).End(xlUp)(1, 8))　　

紅色部份請刪掉（一時筆誤．沒發現）！
取一個欄位即可，多了紅色部份，xArea就變成８個欄區～～

其它大致ｏｋ，就只看資料是否有固定架構，不然也是難以正確執行程式的！


下一行可自動偵測〔欄位〕數：
For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 9

starry1314

回復 14# 准提部林


    感謝~完美達到所要的效果 !!
自動偵測欄位好用多了,
不過不懂為何第一次PO的版本
For i = 1 To 9 Step 4 '共有12個欄位 但不知為何會是9,不是應該是12嗎

准提部林

回復 15# starry1314


間隔４跳三次，１－５－９，再跳一次就１３，所以 1 To 9 或 1 To 12 同樣～～

starry1314

回復 16# 准提部林
了解！感謝指導～!!

starry1314

回復 16# 准提部林

大大 不好意思
又遇到難題了......
底下為各類別的單一品項達20以上即刪除,且單位代號為A的則刪除部分欄位資料
貼紙條件=20
xR(1, 10)=單位代號

目前的難題是...達20以上的數量計算不包含 單位代號不為A
不為A的單位則統一計算
有試著做修改但這樣因為單位代號滿多
  T = xR(1, 5) & xR(1, 6)  改為↓
  T = xR(1, 5) & xR(1, 6) & xR(1, 10)

1. Sub 條件刪除()
   
2. Dim arr, U%
   
3. Dim xArea As Range, xR As Range, xU As Range, xD, T$, I&
   
4. 
   
5. 'For i = 1 To 28 Step 9
   
6. For I = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 10
   
7. '自動偵測欄位數 以9欄為一組
   
8.     Set xD = CreateObject("Scripting.Dictionary")
   
9.     Set xArea = Range(Cells(2, I), Cells(Rows.Count, I).End(xlUp))
   
10.     For Each xR In xArea
    
11.         T = xR(1, 5) & xR(1, 6): xD(T) = xD(T) + 1
    
12.     Next
    
13. '檢查符合刪除條件者，納入 xU 儲存格聯集
    
14.     Set xU = Cells(xArea.Rows.Count + 2, 1)
    
15.     For Each xR In xArea
    
16.         T = xR(1, 5) & xR(1, 6)
    
17.         If xD(T) >= [貼紙條件] And xR(1, 8) = "." And xR(1, 10) = "A" Then Set xU = Union(xU, xR.Resize(1, 3))
    
18.     Next
    
19. '刪除
    
20.    If xU.Count > 1 Then xU = ""  'xU.Delete Shift:=xlUp
    
21.     'If xU.Count > 1 Then xU.Delete Shift:=xlUp
    
22. Next I
    
23.    
    
24. End Sub

複製代碼

starry1314

回復 17# starry1314


    目前的解決方式:將單位代號不屬於A的編號 改為統一的編號再來做運算

准提部林

For Each xR In xArea
　　If xR(1, 10) = "A" Then
　　　T = xR(1, 5) & xR(1, 6)
　　　xD(T) = xD(T) + 1
　　End If
Next

非"A"時，不要處理即可！