Board logo

標題: [發問] 請問如何可統計出現次數並且包含多條件的資料刪除呢? [打印本頁]
作者: starry1314    時間: 2015-10-10 13:41     標題: 請問如何可統計出現次數並且包含多條件的資料刪除呢?

如何設定能將左方原始資料
1.同類別內同品名相同者且數量大於20的
.並且備註欄只有【.】的資料列刪除呢?

主要卡在不知該如何統計此出現次數大於20的項目做刪除
[attach]22176[/attach]
[attach]22177[/attach]
作者: hcm19522    時間: 2015-10-11 11:12

http://blog.xuite.net/hcm19522/twblog/348638247
作者: 准提部林    時間: 2015-10-11 13:07

先將樞紐分析表內容貼至另一工作表!

Sub TEST()
Dim xArea As Range, xR As Range, xU As Range, xD, T$
Set xD = CreateObject("Scripting.Dictionary")
Set xArea = Range([B2], [B65536].End(xlUp))
'以ＢＣ欄值為KEY納入字典檔並累計次數　
For Each xR In xArea
　T = xR & xR(1, 2):  xD(T) = xD(T) + 1
Next
'檢查符合刪除條件者，納入 xU 儲存格聯集　
Set xU = xArea(xArea.Count + 1)
For Each xR In xArea
　T = xR & xR(1, 2)
　If xD(T) >= 20 And xR(1, 3) = "." Then Set xU = Union(xU, xR)
Next
'刪除　
xU.EntireRow.Delete
End Sub
作者: kingvincent    時間: 2015-10-25 21:59

真是受用，感謝分享!!
作者: starry1314    時間: 2015-11-3 22:55

回復 3# 准提部林


    感謝~真是好用！可用在很多地方
作者: starry1314    時間: 2015-11-3 22:55

回復 2# hcm19522


    謝謝∼提供函數用法
作者: starry1314    時間: 2015-11-27 10:04

回復 3# 准提部林
版大∼不好意思　遇到個問題　
再刪除資料時可設定範圍嗎？　因同一活頁內有三張表格，目前此代碼會刪除整列導致另外兩張資料也一併刪除了

如像下列這種　只刪除篩選範圍內資料
  1. With Sheets("數據(早餐)")
  2.         .Select
  3.         .Range("$A$1:AA5000").AutoFilter Field:=6, Criteria1:=Array( _
  4.         "紅茶", "奶茶", "0"), Operator:=xlFilterValues
  5.         
  6.         With .AutoFilter.Range
  7.             .Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).ClearContents
  8.             .AutoFilter
  9.         End With
  10.         
  11.     End With
複製代碼
作者: 准提部林    時間: 2015-11-27 13:27

回復 7# starry1314


請上傳檔案, 並模擬需求結果~~
作者: starry1314    時間: 2015-11-27 14:42

[attach]22631[/attach]回復 8# 准提部林

結果是跟以下代碼一樣的,只是說不要刪除整列 只刪除指定範圍內的資料
  1. Sub TEST()
  2. Dim xArea As Range, xR As Range, xU As Range, xD, T$
  3. Set xD = CreateObject("Scripting.Dictionary")
  4. Set xArea = Range([B2], [B65536].End(xlUp))
  5. '以ＢＣ欄值為KEY納入字典檔並累計次數　
  6. For Each xR In xArea
  7. 　T = xR & xR(1, 2):  xD(T) = xD(T) + 1
  8. Next
  9. '檢查符合刪除條件者，納入 xU 儲存格聯集　
  10. Set xU = xArea(xArea.Count + 1)
  11. For Each xR In xArea
  12. 　T = xR & xR(1, 2)
  13. 　If xD(T) >= 20 And xR(1, 3) = "." Then Set xU = Union(xU, xR)
  14. Next
  15. '刪除　
  16. xU.EntireRow.Delete
  17. End Sub
複製代碼
[attach]22632[/attach]
作者: 准提部林    時間: 2015-11-27 18:06

回復 9# starry1314


Sub TEST()
Dim xArea As Range, xR As Range, xU As Range, xD, T$, i&
For i = 1 To 9 Step 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    時間: 2015-11-27 23:32

回復 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    時間: 2015-11-28 09:40

回復 10# 准提部林

版大~不好意思 現欄位有增加，試過後改不太出來  
只會刪除部份資料 第一表格會全刪,第二、三表格只會刪除部份資料
    [attach]22637[/attach]
作者: starry1314    時間: 2015-11-28 10:10

回復 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
作者: 准提部林    時間: 2015-11-28 10:47

本帖最後由 准提部林 於 2015-11-28 10:57 編輯

回復 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    時間: 2015-11-28 13:19

回復 14# 准提部林


    感謝~完美達到所要的效果 !!
自動偵測欄位好用多了,
不過不懂為何第一次PO的版本
For i = 1 To 9 Step 4 '共有12個欄位 但不知為何會是9,不是應該是12嗎
作者: 准提部林    時間: 2015-11-28 13:33

回復 15# starry1314


間隔４跳三次，１－５－９，再跳一次就１３，所以 1 To 9 或 1 To 12 同樣∼∼
作者: starry1314    時間: 2015-11-28 14:01

回復 16# 准提部林
了解！感謝指導∼!!
作者: starry1314    時間: 2016-8-18 11:36

回復 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&

  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    時間: 2016-8-18 14:30

回復 17# starry1314


    目前的解決方式:將單位代號不屬於A的編號 改為統一的編號再來做運算
作者: 准提部林    時間: 2016-8-19 10:10

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"時，不要處理即可！
作者: starry1314    時間: 2016-8-19 10:48

回復 20# 准提部林


    感謝版大....我想的好複雜....



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