123
返回列表 上一主題 發帖

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

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
11# 跳轉到 »
發表於 2020-10-21 21:56 | 顯示全部帖子
回復 30# wei9133

你把 jcchiang前輩的 以下這段改一下 看看 是不是你要的結果

Sub ex3()
Dim d As Object, ar As Object, r
Dim i%, AA$, a
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set ar = Sheets(1).[a1].CurrentRegion

For i = 1 To ar.Rows.Count
   AA = Join(Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 102))), ",") & "," & ar(i, 106) '建立判斷條件
   If Not d.exists(AA) Then   '字典內查無該條件
      a = Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 115)))
      If a(103) = "" Then a(103) = 1 '勝場空白填入1
      d(AA) = a '將資料放回字典
   Else
      a = Application.Transpose(Application.Transpose(d(AA)))   '將字典資料取出
      If ar(i, 103) = "" Then a(103) = a(103) + 1 Else a(103) = a(103) + ar(i, 103) '勝場空白勝場累加1,不是空白則將欄位值相加
      a(105) = a(105) + ar(i, 105) '敗局累加
      For Each r In Array(104, 107, 109, 115) '將備註,DC,DE,DK欄位資料合併
         If a(r) <> "" And ar(i, r) <> "" Then '如果字典與欄位都有資料,使用","相連
            a(r) = a(r) & "," & ar(i, r)
         ElseIf a(r) = "" And ar(i, r) <> "" Then '如果字典資料為空白,欄位是有資料的,使用欄位資料
            a(r) = ar(i, r)
         End If
      Next
      d(AA) = a   '將資料放回字典
   End If
Next
With Sheets(2)  '在第二個Sheet填入資料
.[a1].CurrentRegion.Clear '清除Sheet資料
.[a1].Resize(d.Count, 115) = Application.Transpose(Application.Transpose(d.items)) '將字典資料列出
'For Each r In .Range(.[cy2], .[cy2].End(4))  '保留勝場+1
'   r.Value = r.Value + 1
'Next
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub

TOP

軒云熊

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

回復 34# wei9133

請問你要的結果是不是這樣
先左右比對 若是 1~51  跟 52~102 相同時 + 星象106 此時(勝率 =  "" 或 敗局 = ""  本身就是 =1 或著 =-1 ?)  當作尋找比對的目標  
再尋找比對上下 1~102 + 星象106 若相同時  在看 103勝率  跟  105敗局 進行累加
累加後的數值要在 合併該列的順序上
合併該列的順序是   先107 A  若 =""  就合併在 109  X   若 ="" 就合併在   115暫存   若 =""  就合併在  104備註
還是說 就像 jcchiang 前輩 跟 准提大大 所說的 這樣複雜的組合算法?
或著能否簡單明瞭就好 我實在不太明白抱歉...小弟數學不好

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
13#
發表於 2020-10-25 01:20 | 顯示全部帖子
回復 34# wei9133

有空幫我看一下 是不是這樣的結果 謝謝

javascript:;

對戰統計 -1025.rar (699.95 KB)

TOP

軒云熊

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

回復 34# wei9133

感覺敗局 怪怪的 所以改了一下 有空幫我看一下 感謝 跑的速度慢了一些 不知如何加快速度.....
  1. Public Sub 練習1025()
  2. Application.ScreenUpdating = False
  3. Sheets(1).Select
  4. Sheets(2).[a1].CurrentRegion.Clear
  5. Dim Arr, D, xD, xD1, x&, y&, k&, T1$, T2$, T3$, T4$
  6. Set xD = CreateObject("Scripting.Dictionary")
  7. Set xD1 = CreateObject("Scripting.Dictionary")
  8. Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(1, 115))
  9. For x = 2 To UBound(Arr, 1)
  10.     T1 = ""
  11.     For y = 1 To 51
  12.         T1 = T1 & Arr(x, y)
  13.         If Arr(x, y) = "" Then T1 = T1 & "-"
  14.     Next y
  15.     T3 = ""
  16.     For y = 52 To 102
  17.         T3 = T3 & Arr(x, y)
  18.         If Arr(x, y) = "" Then T3 = T3 & "-"
  19.     Next y
  20.     If T1 = T3 Then
  21.        T1 = T1 & T3 & Arr(x, 106)
  22.        T3 = ""
  23.         If Arr(x, 103) = "" Then
  24.            Arr(x, 103) = 1
  25.            xD(T1) = xD(T1) + Arr(x, 103)
  26.         ElseIf Arr(x, 103) <> "" Then
  27.            xD(T1) = xD(T1) + Arr(x, 103)
  28.         End If
  29.         xD1(T1) = xD1(T1) + Arr(x, 105)
  30.     End If
  31. Next x
  32. T1 = "": T3 = ""
  33. For Each D In xD
  34.     For x = UBound(Arr, 1) To 2 Step -1
  35.         T2 = ""
  36.         For y = 1 To 51
  37.             T2 = T2 & Arr(x, y)
  38.             If Arr(x, y) = "" Then T2 = T2 & "-"
  39.         Next y
  40.         T4 = ""
  41.         For y = 52 To 102
  42.             T4 = T4 & Arr(x, y)
  43.             If Arr(x, y) = "" Then T4 = T4 & "-"
  44.         Next y
  45.         If T2 = T4 Then
  46.             T2 = T2 & T4 & Arr(x, 106)
  47.             T4 = ""
  48.             If D = T2 Then
  49.                 Arr(x, 103) = xD(D)
  50.                 Arr(x, 105) = xD1(D)
  51.             End If
  52.         End If
  53.     Next x
  54. Next D
  55. T2 = "": T4 = "": D = "": k = 1
  56. For x = 2 To UBound(Arr, 1)
  57.     If Arr(x, 103) <> "" Or Arr(x, 105) <> "" Then
  58.         If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  59.         Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  60.             k = k + 1
  61.         End If
  62.         For y = 1 To UBound(Arr, 2)
  63.             If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  64.             Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  65.                 Arr(k, y) = Arr(x, y)
  66.             End If
  67.         Next y
  68.     End If
  69. Next x
  70. Set xD = Nothing
  71. Set xD1 = Nothing
  72. Sheets(2).Range("A1").Resize(k, UBound(Arr, 2)) = ""
  73. Sheets(2).Range("A1").Resize(k, UBound(Arr, 2)) = Arr
  74. Erase Arr
  75. Sheets(2).Select
  76. Application.ScreenUpdating = True
  77. End Sub
複製代碼

TOP

軒云熊

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

有空幫我看一下 是不是這樣  如果有問題 請告訴我問題出在哪裡 感謝
javascript:;

對戰統計 -1030.rar (32.61 KB)

TOP

軒云熊

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

回復 43# wei9133

或著改成這樣 看看 是不是你要的結果  還是說  jcchiang前輩 的才是你要的結果
  1. Public Sub 練習1030()
  2. Sheets(2).Select
  3. Rows(2).Select
  4. ActiveWindow.FreezePanes = False
  5. Application.ScreenUpdating = False
  6. Sheets(2).[a1].CurrentRegion.Clear
  7. Sheets(1).Select
  8. Dim Arr, d, xD, x&, y&, k&, T1$, T2$, T3$, T4$
  9. Set xD = CreateObject("Scripting.Dictionary")
  10. Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(1, 115))
  11. For x = 2 To UBound(Arr, 1)
  12.     T1 = ""
  13.     For y = 1 To 51
  14.         T1 = T1 & Arr(x, y)
  15.         If Arr(x, y) = "" Then T1 = T1 & "-"
  16.     Next y
  17.     T3 = ""
  18.     For y = 52 To 102
  19.         T3 = T3 & Arr(x, y)
  20.         If Arr(x, y) = "" Then T3 = T3 & "-"
  21.     Next y
  22.     If T1 = T3 Then
  23.        T1 = T1 & T3 & Arr(x, 106)
  24.        T3 = ""
  25.         If Arr(x, 103) = "" Then
  26.            Arr(x, 103) = 1
  27.            xD(T1) = xD(T1) + Arr(x, 103)
  28.         ElseIf Arr(x, 103) <> "" Then
  29.            xD(T1) = xD(T1) + Arr(x, 103)
  30.         End If
  31.         xD(T1 & 105) = xD(T1 & 105) + Arr(x, 105)
  32.     End If
  33. Next x
  34. T1 = "": T3 = ""
  35. For Each d In xD
  36.     For x = UBound(Arr, 1) To 2 Step -1
  37.         T2 = ""
  38.         For y = 1 To 51
  39.             T2 = T2 & Arr(x, y)
  40.             If Arr(x, y) = "" Then T2 = T2 & "-"
  41.         Next y
  42.         T4 = ""
  43.         For y = 52 To 102
  44.             T4 = T4 & Arr(x, y)
  45.             If Arr(x, y) = "" Then T4 = T4 & "-"
  46.         Next y
  47.         If T2 = T4 Then
  48.             T2 = T2 & T4 & Arr(x, 106)
  49.             T4 = ""
  50.             If d = T2 Then
  51.                 E = E + 1
  52.                 If E = 1 Then
  53.                    If Arr(x, 103) > 0 Then Arr(x, 103) = xD(d)
  54.                    If Arr(x, 103) <= 1 Then Arr(x, 103) = ""
  55.                 Else
  56.                     Arr(x, 103) = xD(d) - 1
  57.                     If Arr(x, 103) < 0 Then Arr(x, 103) = Arr(x, 103) * -1
  58.                 End If
  59.                 Arr(x, 105) = xD(d & 105)
  60.                 If xD(d & 105) = 0 Then Arr(x, 105) = ""
  61.             End If
  62.         End If
  63.     Next x
  64.     E = 0
  65. Next d
  66. T2 = "": T4 = "": d = "": k = 1
  67. Set xD = Nothing
  68. For x = 2 To UBound(Arr, 1)
  69.     If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  70.     Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  71.         k = k + 1
  72.         For y = 1 To UBound(Arr, 2)
  73.             Arr(k, y) = Arr(x, y)
  74.         Next y
  75.     End If
  76. Next x
  77. T2 = "": T4 = ""
  78. Sheets(2).Range("A1").Resize(k, UBound(Arr, 2)) = ""
  79. Sheets(2).Range("A1").Resize(k, UBound(Arr, 2)) = Arr
  80. Erase Arr
  81. Application.ScreenUpdating = True
  82. Sheets(2).Select
  83. Rows(2).Select
  84. ActiveWindow.FreezePanes = True
  85. Cells(Rows.Count, 106).End(xlUp).Select
  86. End Sub
複製代碼

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
17#
發表於 2020-10-30 10:09 | 顯示全部帖子
回復 43# wei9133
抱歉剛才發現累加勝率有問題 改一下  有控再幫我看一下  感謝


javascript:;

對戰統計 -1030_01.rar (33.82 KB)

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2025-6-21 
18#
發表於 2020-10-30 20:30 | 顯示全部帖子
回復 49# 准提部林


感謝 準大指導 不知道這樣改 是不是有接近 準大說的方法
看起來還是有差很多 結果與 jcchiang前輩的不同  不知如何修改...
  1. Public Sub 練習1030_02()
  2. Sheets(2).Select
  3. Rows(2).Select
  4. ActiveWindow.FreezePanes = False
  5. Application.ScreenUpdating = False
  6. Sheets(2).[a1].CurrentRegion.Clear
  7. Sheets(1).Select
  8. Dim Arr, D, xD, x&, y&, k&, T1$, T2$, T3$, T4$
  9. Set xD = CreateObject("Scripting.Dictionary")
  10. Arr = Range(Cells(Rows.Count, 1).End(xlUp), Cells(1, 115))
  11. For x = 2 To UBound(Arr, 1)
  12.     T1 = ""
  13.     For y = 1 To 51
  14.         T1 = T1 & Arr(x, y)
  15.         If Arr(x, y) = "" Then T1 = T1 & "-"
  16.     Next y
  17.     T3 = ""
  18.     For y = 52 To 102
  19.         T3 = T3 & Arr(x, y)
  20.         If Arr(x, y) = "" Then T3 = T3 & "-"
  21.     Next y
  22.     If T1 = T3 Then
  23.         T1 = T1 & T3 & Arr(x, 106)
  24.         T3 = ""
  25.         If Arr(x, 103) = "" Then
  26.            Arr(x, 103) = 1
  27.            xD(T1) = xD(T1) + Arr(x, 103)
  28.         ElseIf Arr(x, 103) <> "" Then
  29.            xD(T1) = xD(T1) + Arr(x, 103) + 1
  30.         End If
  31.         xD(T1 & 105) = xD(T1 & 105) + Arr(x, 105)
  32.     End If
  33. Next x
  34. T1 = "": k = 1
  35. For Each D In xD
  36.     For x = 2 To UBound(Arr, 1)
  37.         T2 = ""
  38.         For y = 1 To 51
  39.             T2 = T2 & Arr(x, y)
  40.             If Arr(x, y) = "" Then T2 = T2 & "-"
  41.         Next y
  42.         T4 = ""
  43.         For y = 52 To 102
  44.             T4 = T4 & Arr(x, y)
  45.             If Arr(x, y) = "" Then T4 = T4 & "-"
  46.         Next y
  47.         If T2 = T4 Then
  48.             T2 = T2 & T4 & Arr(x, 106)
  49.             T4 = ""
  50.             If D = T2 Then
  51.                 k = k + 1
  52.                 Arr(x, 103) = xD(D) - 1
  53.                 Arr(x, 105) = xD(D & 105)
  54.                 If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  55.                 Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  56.                      For y = 1 To UBound(Arr, 2)
  57.                          Arr(k, y) = Arr(x, y)
  58.                          If Arr(k, 103) = 0 Then Arr(k, 103) = ""
  59.                          If Arr(k, 105) = 0 Then Arr(k, 105) = ""
  60.                      Next y
  61.                 Exit For
  62.                 End If
  63.             End If
  64.         End If
  65.     Next x
  66. Next D
  67. T2 = "": Set xD = Nothing
  68. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = ""
  69. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = Arr
  70. Erase Arr
  71. Application.ScreenUpdating = True
  72. Sheets(2).Select
  73. Rows(2).Select
  74. ActiveWindow.FreezePanes = True
  75. Cells(Rows.Count, 106).End(xlUp).Select
  76. End Sub
複製代碼

TOP

軒云熊

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

回復 41# wei9133

請問 勝率 理論上應該是   勝率 = 勝場/(勝場+敗局)*100%   是否是這樣?
如果 +1  -1  好像怪怪的
Cells(x, 116) = Format(Cells(x, 103) / (Cells(x, 103) + Cells(x, 105)), "###%")

TOP

軒云熊

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

回復 55# wei9133

你有新增 工作表嗎?  用這個試試看  
我有把 jcchiang前輩的也放進去了  Sub ex5()  結果不太一樣  
再看看我哪裡有問題在告訴我 感謝

javascript:;

對戰統計 -1102_.rar (32.4 KB)

TOP

        靜思自在 : 天上最美是星星，人生最美是溫情。
123
返回列表 上一主題