[發問] 請問如何可統計出現次數並且包含多條件的資料刪除呢?

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

2^#

發表於 2015-11-3 22:55 | 顯示全部帖子

回復 3# 准提部林

感謝~真是好用！可用在很多地方

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

3^#

發表於 2015-11-3 22:55 | 顯示全部帖子

回復 2# hcm19522

謝謝～提供函數用法

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

4^#

發表於 2015-11-27 10:04 | 顯示全部帖子

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

如像下列這種　只刪除篩選範圍內資料

With Sheets("數據(早餐)")
.Select
.Range("$A$1:AA5000").AutoFilter Field:=6, Criteria1:=Array( _
"紅茶", "奶茶", "0"), Operator:=xlFilterValues
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).ClearContents
.AutoFilter
End With
End With

複製代碼

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

5^#

發表於 2015-11-27 14:42 | 顯示全部帖子

多條件判斷刪除.rar (16.02 KB) 回復 8# 准提部林

結果是跟以下代碼一樣的,只是說不要刪除整列只刪除指定範圍內的資料

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

複製代碼

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

6^#

發表於 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

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

7^#

發表於 2015-11-28 09:40 | 顯示全部帖子

回復 10# 准提部林

版大~不好意思現欄位有增加，試過後改不太出來
只會刪除部份資料第一表格會全刪,第二、三表格只會刪除部份資料

多條件判斷刪除-2.rar (92.51 KB)

　暱稱: 豪

帖子: 471
主題: 121
精華: 0
積分: 579
點名: 0
作業系統: WIN10
軟體版本: OFFICE2019
閱讀權限: 50
性別: 男
註冊時間: 2015-4-16
最後登錄: 2023-1-17

8^#

發表於 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