1234567
返回列表 上一主題 發帖

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

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
61# 跳轉到 »
發表於 2020-11-14 22:22 | 只看該作者
回復 59# wei9133

如果左右不用比對 那就直接比對星象 再進行勝場 跟 敗場 加總可以嗎?

TOP

軒云熊

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

有空幫我試試看  這個應該可以  但是有一個很大的問題 ...如果資料很多 會跑非常慢....
  1. Public Sub 練習1116()
  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.     T1 = T1 & T3 & Arr(x, 106)
  23.     T3 = ""
  24.     If Arr(x, 103) = "" Then
  25.         Arr(x, 103) = 1
  26.         xD(T1) = xD(T1) + Arr(x, 103)
  27.     ElseIf Arr(x, 103) <> "" Then
  28.         xD(T1) = xD(T1) + Arr(x, 103) + 1
  29.     End If
  30.     xD(T1 & 105) = xD(T1 & 105) + Arr(x, 105)
  31.     xD(Arr(x, 106)) = xD(Arr(x, 106)) + 1
  32. Next x
  33. T1 = "": k = 2
  34. For Each D In xD
  35.     For x = 2 To UBound(Arr, 1)
  36.         T2 = ""
  37.         For y = 1 To 51
  38.             T2 = T2 & Arr(x, y)
  39.             If Arr(x, y) = "" Then T2 = T2 & "-"
  40.         Next y
  41.         T4 = ""
  42.         For y = 52 To 102
  43.             T4 = T4 & Arr(x, y)
  44.             If Arr(x, y) = "" Then T4 = T4 & "-"
  45.         Next y
  46.         T2 = T2 & T4 & Arr(x, 106)
  47.         T4 = ""
  48.         If D = T2 Then
  49.             Arr(x, 103) = xD(D) - 1
  50.             Arr(x, 105) = xD(D & 105)
  51.             If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  52.             Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  53.                  For y = 1 To UBound(Arr, 2)
  54.                      Arr(k, y) = Arr(x, y)
  55.                  Next y
  56.             k = k + 1
  57.             Exit For
  58.             End If
  59.         End If
  60.         If D = Arr(x, 106) And xD(D) = 1 _
  61.         And Arr(x, 107) = "" And Arr(x, 109) = "" _
  62.         And Arr(x, 115) = "" And Arr(x, 104) = "" Then
  63.             For y = 1 To UBound(Arr, 2)
  64.                 Arr(k, y) = Arr(x, y)
  65.             Next y
  66.         k = k + 1
  67.         Exit For
  68.         End If
  69.     Next x
  70. If Arr(k - 1, 103) = 0 Then Arr(k - 1, 103) = ""
  71. If Arr(k - 1, 105) = 0 Then Arr(k - 1, 105) = ""
  72. Debug.Print k
  73. Debug.Print D
  74. Next D
  75. T2 = "": Set xD = Nothing
  76. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = ""
  77. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = Arr
  78. Erase Arr
  79. Application.ScreenUpdating = True
  80. Sheets(2).Select
  81. Rows(2).Select
  82. ActiveWindow.FreezePanes = True
  83. Cells(Rows.Count, 106).End(xlUp).Select
  84. End Sub
複製代碼

TOP

軒云熊

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

這會比較快一點 但是還是很慢... 有空幫我試試看有沒有問題   感謝
  1. Public Sub 練習1118()
  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$, T3$, E()
  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.     T1 = T1 & T3 & Arr(x, 106)
  23.     ReDim Preserve E(x)
  24.     E(x) = T1
  25.     T3 = ""
  26.     If Arr(x, 103) = "" Then
  27.         Arr(x, 103) = 1
  28.         xD(T1) = xD(T1) + Arr(x, 103)
  29.     ElseIf Arr(x, 103) <> "" Then
  30.         xD(T1) = xD(T1) + Arr(x, 103) + 1
  31.     End If
  32.     xD(T1 & 105) = xD(T1 & 105) + Arr(x, 105)
  33.     xD(Arr(x, 106)) = xD(Arr(x, 106)) + 1
  34. Next x
  35. T1 = "": k = 2
  36. For Each D In xD
  37.     For x = 2 To UBound(Arr, 1)
  38.         If D = E(x) Then
  39.             Arr(x, 103) = xD(D) - 1
  40.             Arr(x, 105) = xD(D & 105)
  41.             If Arr(x, 107) <> "" Or Arr(x, 109) <> "" _
  42.             Or Arr(x, 115) <> "" Or Arr(x, 104) <> "" Then
  43.                  For y = 1 To UBound(Arr, 2)
  44.                      Arr(k, y) = Arr(x, y)
  45.                  Next y
  46.             k = k + 1
  47.             Exit For
  48.             End If
  49.         End If
  50.         If D = E(x) And xD(D) = 1 _
  51.         And Arr(x, 107) = "" And Arr(x, 109) = "" _
  52.         And Arr(x, 115) = "" And Arr(x, 104) = "" Then
  53.             For y = 1 To UBound(Arr, 2)
  54.                 Arr(k, y) = Arr(x, y)
  55.             Next y
  56.         k = k + 1
  57.         Exit For
  58.         End If
  59.     Next x
  60. If Arr(k - 1, 103) = 0 Then Arr(k - 1, 103) = ""
  61. If Arr(k - 1, 105) = 0 Then Arr(k - 1, 105) = ""
  62. Next D
  63. Set xD = Nothing: Erase E
  64. Sheets(2).Range("A1").Resize(k - 1, UBound(Arr, 2)) = Arr
  65. Erase Arr
  66. Application.ScreenUpdating = True
  67. Sheets(2).Select
  68. Rows(2).Select
  69. ActiveWindow.FreezePanes = True
  70. Cells(Rows.Count, 106).End(xlUp).Select
  71. End Sub
複製代碼

TOP

軒云熊

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

剛才試了一下發現 106星象有問題 改了一下  ，有空再幫我試試看 有沒有問題，感謝

javascript:;

對戰統計 -1120_.rar (652.91 KB)

TOP

        靜思自在 : 小事不做、大事難成。
1234567
返回列表 上一主題