1234567
返回列表 上一主題 發帖

[發問] vba的篩選功能 (取消部分篩選)

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
25# 跳轉到 »
發表於 2020-10-16 19:23 | 只看該作者
本帖最後由 軒云熊 於 2020-10-16 19:26 編輯

回復 23# wei9133

檔案無法開啟 看要不要再上傳一次 不用全部 有部分 可以測試 就可以了
你先看看 jcchiang前輩  寫的是不是你要的邏輯   因為jcchiang前輩的寫法速度會快很多

javascript:;

1016.png (19.96 KB)

1016.png

TOP

jcchiang

帖子
234 
主題
19 
精華
0 
積分
276 
點名
0  
作業系統
Windows XP 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
註冊時間
2013-1-7 
最後登錄
2021-10-7 
24#
發表於 2020-10-16 08:39 | 只看該作者
回復 23# wei9133

1.mega的檔案因公司限制無法下載,所以使用前面的檔案內容寫
2.A~CV+星象 相同的列統計其勝場&敗局(使用檔案內欄位的值累計)
3.保留的列勝場多加1
4.勝場為空白的填入1,視勝場為1
5.程式無執行刪除列的動作,將資料列在[a400]位置
以上是我能理解的部份

Sub ex3()
Dim d As Object, ar As Object, r As Object
Dim i%, AA$, a

Set d = CreateObject("Scripting.Dictionary")
Set ar = [A1].CurrentRegion

For i = 1 To ar.Rows.Count
   AA = Join(Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 100))), ",") & "," & ar(i, 104) '建立判斷條件
   If ar(i, 101) = "" Then ar(i, 101) = 1 '勝場空白填入1
   If Not d.exists(AA) Then   '字典內查無該條件
      d(AA) = ar(i, 1).Resize(, 104) '增加字典資料
   Else
      a = Application.Transpose(Application.Transpose(d(AA)))   '將字典資料取出
      a(101) = a(101) + ar(i, 101) '勝率累加
      a(102) = a(102) + 1           '備註:相符的筆數(不包含第一筆)
      a(103) = a(103) + ar(i, 103) '敗局累加
      d(AA) = a   '將資料放回字典
   End If
Next
[a400].Resize(d.Count, 104) = Application.Transpose(Application.Transpose(d.items)) '將字典資料列出
For Each r In Range([cw401], [cw401].End(4))  '保留勝場+1
   r.Value = r.Value + 1
Next
Set d = Nothing
End Sub

TOP

wei9133

帖子
58 
主題
9 
精華
0 
積分
117 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
註冊時間
2017-12-2 
最後登錄
2021-12-16 
23#
發表於 2020-10-15 06:54 | 只看該作者
本帖最後由 wei9133 於 2020-10-15 06:56 編輯

回復 22# 軒云熊

你好，因為後面這個已經變成比對了，所以跟一開始的作法已經不一樣
然後這兩天又增加新英雄，所以格子又不一樣了..

而比對的部分因為後面還加上整合成一行的部分
那就又必須考慮到幾個條件
1.A~CX(敗勝雙方出陣) & DB(星象)長的一模一樣的列
2.有些比較常出現的組合會有暫存的篩選快捷，裡面也有值的
  具體是CZ(備註)DC跟DE有雙方出陣的簡寫方便篩選後快速辨識
  (看不懂的話執行 "Sub 暫存篩選()"快捷鍵 ctrl+L，會比較好理解)
  或著這樣講判斷 上面這三個其中一個有值的，合併的基本就是它，把其他的勝敗場都加到這一列上面
  
3.所以是把符合"條件一"的列去比對，全部加在符合"條件二"的列上面，然後把該列的勝敗場都加起來填在各自的勝敗場
  要被合併的勝場該欄位數字要加1，因為出現這一列本身就是勝了一場，多勝一場才會在在勝場數上加上數字
  而敗場則否
  譬如
  共有三列符合上述所有條件 A~CX相同、DB相同
  而勝場部份的值則分別為3、空格、1，敗場的值則為1、空格、空格
  算出來合併的勝場欄位應為"6"，敗場則為"1"
  算法是這樣的，假設3那格保留，而空格代表勝1場，勝場填入1的實際上是"當列"加"勝1場"
  所以加出來是"6"

https://mega.nz/file/7dQmCLjI#QCQsI9fga6rZlsXJYLfrfaGz2ZUVmFLaCXtTOLFNvqI
我直接附上檔案，你用此檔案測試即可，有原始檔案也有助於你理解我說的到底是甚麼
當然如果有更好的方法也請提出
至於如果有幸有寫出vba程式碼的話
煩請直接回覆於帖子之中
(因為後續還會有新英雄加入，所以麻煩幫我註解若格子往後推的話要改哪個地方)


上面檔案中已有巨集，如有疑慮可以不開啟
巨集功用分別為Module2 塗底色(格式化條件)
Module1 篩選(V|W|空格|非空格|取消篩選)/字型顏色加粗

P.S.要注意版本用的是EXCEL 2003，我不清楚VBA的版本是否通用。

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
22#
發表於 2020-10-12 05:30 | 只看該作者
回復 18# wei9133

剛才發現跑太久了 所以改了一下 有比較好一點 但是還是很慢
  1. Public Sub 多列比對練習()
  2. Application.ScreenUpdating = False
  3. Dim Arr, i&, j&, t&, tj&, x&, y&, T1$, T2$, T3$, T4$
  4. Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(2, 100))
  5.     For t = 1 To UBound(Arr, 1)
  6.             TI = "": T2 = ""
  7.             For tj = 1 To UBound(Arr, 2)
  8.                 If Arr(t, tj) = "" Then
  9.                    Arr(t, tj) = "-"
  10.                    Arr(t, tj) = Arr(t, tj) & Arr(t, tj)
  11.                 End If
  12.                 T1 = Arr(t, tj)
  13.                 T2 = T2 & T1
  14.                 If tj = UBound(Arr, 2) Then T2 = T2 & Cells(t + 1, 104)
  15.             Next tj
  16.         For i = UBound(Arr, 1) To t + 1 Step -1
  17.             T3 = "": T4 = ""
  18.             For j = 1 To UBound(Arr, 2)
  19.                 If Arr(i, j) = "" Then
  20.                    Arr(i, j) = "-"
  21.                    Arr(i, j) = Arr(i, j) & Arr(i, j)
  22.                 End If
  23.                 T3 = Arr(i, j)
  24.                 T4 = T4 & T3
  25.                 If j = UBound(Arr, 2) Then T4 = T4 & Cells(i + 1, 104)
  26.             Next j
  27.             If T4 = T2 Then
  28.                 Cells(t + 1, 101) = Cells(t + 1, 101) + Cells(t + 1, 101)
  29.                 Cells(i + 1, 101) = Cells(i + 1, 101) + Cells(i + 1, 101)
  30.                 Cells(t + 1, 103) = Cells(t + 1, 103) - Cells(t + 1, 103)
  31.                 Cells(i + 1, 103) = Cells(i + 1, 103) - Cells(i + 1, 103)
  32.                 Cells(t + 1, 104).Interior.Color = RGB(255, 255, 0)
  33.                 Cells(i + 1, 104).Interior.Color = RGB(255, 255, 0)
  34.             End If
  35.         Next i
  36.     Next t
  37.     For x = 2 To Cells(2, 1).End(xlDown).Row
  38.         For y = Cells(2, 1).End(xlDown).Row To x + 1 Step -1
  39.             If Cells(x, 104).Interior.Color = RGB(255, 255, 0) _
  40.             And Cells(y, 104).Interior.Color = RGB(255, 255, 0) Then
  41.             If Cells(x, 104) = Cells(y, 104) Then
  42.                Rows(y).Delete
  43.             End If
  44.         End If
  45.         Next y
  46.     Next x
  47. Application.ScreenUpdating = True
  48. End Sub
複製代碼

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
21#
發表於 2020-10-12 04:15 | 只看該作者
本帖最後由 軒云熊 於 2020-10-12 04:24 編輯

回復 19# wei9133
把 勝率 跟 敗局 改為有重複就加1 有空再幫我看看 是不是這樣 謝謝
  1. Public Sub 多列比對練習()
  2. Application.ScreenUpdating = False
  3. Dim Arr, i&, t&, A1$, A2$
  4. Arr = Range(Sheets(3).Cells(Rows.Count, 1).End(xlUp), Sheets(3).Cells(2, 100))
  5. ReDim A(LBound(Arr) To UBound(Arr))
  6.     '多列比對
  7.     For t = 1 To UBound(Arr, 1)
  8.         For i = UBound(Arr, 1) To t + 1 Step -1
  9.         A1 = 串聯_文字(Application.WorksheetFunction.Index(Arr, t, 0))
  10.         A2 = 串聯_文字(Application.WorksheetFunction.Index(Arr, i, 0))
  11.         A1 = A1 & Cells(t + 1, 104)
  12.         A2 = A2 & Cells(i + 1, 104)
  13.         If A1 = A2 Then
  14.             Cells(t + 1, 101) = Cells(t + 1, 101) + 1
  15.             Cells(i + 1, 101) = Cells(i + 1, 101) + 1
  16.             Cells(t + 1, 103) = Cells(t + 1, 103) + 1
  17.             Cells(i + 1, 103) = Cells(i + 1, 103) + 1
  18.             Cells(t + 1, 104).Interior.Color = RGB(255, 255, 0)
  19.             Cells(i + 1, 104).Interior.Color = RGB(255, 255, 0)
  20.         End If
  21.         Next i
  22.     Next t
  23.     '刪除重複
  24.     For X = 2 To Cells(2, 1).End(xlDown).Row
  25.         For Y = Cells(2, 1).End(xlDown).Row To X + 1 Step -1
  26.             If Cells(X, 104).Interior.Color = RGB(255, 255, 0) _
  27.             And Cells(Y, 104).Interior.Color = RGB(255, 255, 0) Then
  28.             If Cells(X, 104) = Cells(Y, 104) Then
  29.                Rows(Y).Delete
  30.             End If
  31.         End If
  32.         Next Y
  33.     Next X
  34. Application.ScreenUpdating = True
  35. End Sub
  36. Public Function 串聯_文字(A)
  37.         f = ""
  38.         For i = 1 To UBound(A)
  39.             If A(i) = "" Then A(i) = "-"
  40.             f = f & A(i)
  41.         Next i
  42.         串聯_文字 = f
  43. End Function
複製代碼

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
20#
發表於 2020-10-9 09:52 | 只看該作者
本帖最後由 軒云熊 於 2020-10-9 10:06 編輯

回復 19# wei9133

你要先把 工作表2 刪除 再新增一個 工作表2在執行     工作表2 是複製的內容 我沒有動工作表1的內容  執行 Module1
  1. Public Sub 多列比對練習()
  2.     Sheets(2).Select
  3.     Rows("2:2").Select
  4.     ActiveWindow.FreezePanes = False '關閉凍結視窗
  5.     Application.ScreenUpdating = False
  6.     Call 巨集1 '錄製的排序
  7.     k = 1

  9.     For X = Cells(1, 1).End(xlDown).Row To 2 Step -1
  10.         A = Range(Cells(X, 49), Cells(X, 1)) '把1~49內容 放到陣列
  11.         B = Range(Cells(X, 99), Cells(X, 51)) '把51~99內容 放到陣列
  12.         
  13.         For I = 1 To UBound(B, 2) '串聯 "-" 號方便比對
  14.             If A(1, k) = "" Then A(1, k) = "-"
  15.             If B(1, I) = "" Then B(1, I) = "-"
  16.             f = f & A(1, k)
  17.             r = r & B(1, I)
  18.             If k <= UBound(A, 2) Then k = k + 1
  19.         Next I
  20.         
  21.         k = 1
  22.         
  23.         If f = r And f <> "-" Then '若1~49 與 51~99 相同 就在 勝率欄位 輸入"1"並反黃色
  24.             Cells(X, 101) = "1"
  25.             Cells(X, 101).Interior.Color = RGB(255, 255, 0)
  26.         End If
  27.         
  28.         f = "": r = ""
  29.     Next X

  31.     Call 巨集2 '錄製的刪除重複
  32.     Application.ScreenUpdating = True
  33.     Rows("2:2").Select
  34.     ActiveWindow.FreezePanes = True  '開啟凍結視窗


  37. End Sub
複製代碼

TOP

wei9133

帖子
58 
主題
9 
精華
0 
積分
117 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
註冊時間
2017-12-2 
最後登錄
2021-12-16 
19#
發表於 2020-10-9 01:06 | 只看該作者
本帖最後由 wei9133 於 2020-10-9 01:16 編輯

回復 17# wei9133

我把我具體的操作錄成影片了，看一下或許能懂?

https://sendvid.com/suu270r2

其中整欄直接篩選成V或W的部分因為我已經錄成巨集所以沒有去拉下拉式選單
  1. Sub 篩選為V() '^U
  2. Dim i As Integer
  3. i = ActiveCell.Column '獲取欄位值
  4. Cells(1, i).Select
  5.     Selection.AutoFilter Field:=i, Criteria1:="V"
  6.     '將該格篩選為"V"
  7. End Sub
  8. Sub 篩選為W() '^I
  9. Dim i As Integer
  10. i = ActiveCell.Column '獲取欄位值
  11. Cells(1, i).Select
  12.     Selection.AutoFilter Field:=i, Criteria1:="W"
  13.     '將該格篩選為"W"
  14. End Sub
  15. Sub 篩選為空格() '^B
  16. Dim i As Integer
  17. i = ActiveCell.Column '獲取欄位值
  18. Cells(1, i).Select
  19.     Selection.AutoFilter Field:=i, Criteria1:="="
  20.     '將該格篩選為"空格"
  21. End Sub
  22. Sub 篩選為非空格() 'O
  23. Dim i As Integer
  24. i = ActiveCell.Column '獲取欄位值
  25. Cells(1, i).Select
  26.     Selection.AutoFilter Field:=i, Criteria1:="<>"
  27.     '將該格篩選為"非空格"
  28. End Sub

  30. Sub 篩選為全選() '^+Q
  31. Dim i As Integer
  32. i = ActiveCell.Column '獲取欄位值
  33. Cells(1, i).Select
  34.     Selection.AutoFilter Field:=i ' Criteria1:="<>" ，看起來沒有給後面這串指定值就是全部了
  35.     '將該格篩選為"全部"
  36. End Sub
複製代碼
一開始我需要的功能需求其實是這個
在我選完某一邊之後，把另一邊全部由篩選下拉式選單選回"全選"

https://sendvid.com/3ifimegq

所以才會出現這種東西
  1. sub 篩選後端  ()
  2. Sub 篩選後端()
  3. Dim var_min, var_max, i, j, s As Integer
  4. var_min = 51  '後半段起
  5. var_max = 99  '後半段迄
  6. For j = var_min To var_max
  7. j = j + 1
  8. Cells(1, j).Select
  9. Selection.AutoFilter Field:=j
  10. Next j
  11. End Sub
複製代碼
但是這組代碼好像沒用，所以才會來問

TOP

wei9133

帖子
58 
主題
9 
精華
0 
積分
117 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
註冊時間
2017-12-2 
最後登錄
2021-12-16 
18#
發表於 2020-10-9 00:46 | 只看該作者
回復 16# 軒云熊
我其實也沒看懂你的東西，只有一個活頁簿的東西怎麼變成兩個了
而且我執行它還報錯了



我要比對的始終在一個活頁簿裡
目前是人工挑選A~CV都長得一模一樣且CZ也一樣的部分
然後加總敗場跟勝場數填入其中一列的該格中留存
剩下刪除

TOP

wei9133

帖子
58 
主題
9 
精華
0 
積分
117 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
註冊時間
2017-12-2 
最後登錄
2021-12-16 
17#
發表於 2020-10-9 00:30 | 只看該作者
回復 14# jcchiang

其實我實際上就是比對，不過是人工比對
所以才會想要固定一邊的篩選後條件，將另外半邊全部點回原始未被篩選的狀態
這樣方便看另一邊是否有一樣的組合
這張圖表裡面顯示不出敗局，因為敗局是紀錄的時候發現輸了手動填上的
所以實際比對目標應該是
A~CV都長得一模一樣且CZ也一樣的部分
A~CV分別應對勝敗方的出場人物，而CZ是星象(這個參數雙方共用)
A~AW是敗方組合，AY~CU是敗方組合
AX跟CV這兩格出戰人數是勝敗方的出戰人數，以確保未統計錯誤
(正常為5，若錯了有用格式化標出以發現輸入錯誤)

目前我人工統計的流程是
先固定左邊的篩選條件，這樣篩選出來的敗方角色就被固定了 (反之就是固定勝方篩選條件再去挑選敗方角色)
再從右邊挑選條件篩選，發現兩條長的一模一樣的(A~CV & CZ)，確認一下備註(CX)的顏色階級
(有可能A~CV都一樣但ZC是不同的)

(現在看起來短是因為隱藏了中間的部分)
然後把這幾條一樣的勝場(CW)敗場(CY)加起來填到要留下的那一條的勝場(CW)敗場(CY)欄位
(這個時候我會看一下備註決定要留哪一條)
然後把留下之外的其他條刪除。

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
16#
發表於 2020-10-8 23:20 | 只看該作者
本帖最後由 軒云熊 於 2020-10-8 23:21 編輯

回復 13# wei9133

這是修改過的  順序是 1~49 與 51~99 相同  勝率=1 -> 錄製的排序->錄製的刪除重複
錄製的刪除重複有點怪怪的 不過還是可以用 我找不到原因 刪除後 格式還是會存在但數值文字已被刪除
修改範圍後 刪除的列位不會往上補 >"< 後來又改回來...不知道為甚麼..呵
影片看起來是這樣 不知道是不是你要的 我也是順便練習
  
javascript:;

zz1008.rar (53.2 KB)

TOP

        靜思自在 : 我們要做好社會的環保，也要做好內心的環保。
1234567
返回列表 上一主題