123
返回列表 上一主題 發帖

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

軒云熊

帖子
253 
主題
5 
精華
0 
積分
308 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-3-20 
1# 跳轉到 »
發表於 2020-10-7 12:28 | 顯示全部帖子
回復 6# ikboy
請問你的意思是 篩選後的結果再篩選一次或著更多次嗎?

TOP

軒云熊

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

回復 1# wei9133

並排顯示嗎?
  1. Sub 垂直並排顯示加篩選()
  2.     Application.ScreenUpdating = False
  3.     ActiveWindow.NewWindow '開啟多個相同工作簿
  4.     Windows.Arrange ArrangeStyle:=xlVertical '垂直並排顯示
  5.    
  6.     Windows("zz.xls:1").Activate '切換到工作表2
  7.     Sheets(2).Cells(51, 1).AutoFilter '篩選工作表2
  8.     Sheets(2).Select '點選工作表2

  10.     Windows("zz.xls:2").Activate '切換到工作表1
  11.     Sheets(1).Cells(1, 1).AutoFilter '篩選工作表1
  12.     Application.ScreenUpdating = True
  13. End Sub
複製代碼

TOP

軒云熊

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

回復 10# wei9133

A~L 原本的資料格式要保留嗎?  還是只保留篩選後的?
M~Z 不做任何動作?
這樣的話 A~L 的格式資料會改變 無法復原 因為是 先刪除   A~L 的資料 在貼上篩選後的資料  如果是在同一個活頁簿裡
或著 直接新增一個 新的 工作表在把結果貼上 ?
我看一下 影片好了 >"<

TOP

軒云熊

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

回復 13# wei9133
這不是用篩選 而是用比對的方式  
你看一下是不是這樣?
  1. Public Sub 比對練習()
  2.     Application.ScreenUpdating = False
  3.     Dim A, B, i, k
  4.     k = 1
  5.     E = 345
  6.     For X = 1 To Cells(1, 1).End(xlDown).Row
  7.         A = Range(Cells(X, 49), Cells(X, 1))
  8.         B = Range(Cells(X, 99), Cells(X, 51))
  9.         
  10.         For i = 1 To UBound(B, 2)
  11.         If A(1, k) = "" Then A(1, k) = "-"
  12.         If B(1, i) = "" Then B(1, i) = "-"
  13.              f = f & A(1, k)
  14.              r = r & B(1, i)
  15.             If k <= UBound(A, 2) Then k = k + 1
  16.         Next i
  17.         
  18.         k = 1
  19.         
  20.         If f = r Then
  21.            Cells(E, 1).Resize(1, 104) = Cells(X, 1).Resize(1, 104).Value
  22.            E = E + 1
  23.         End If
  24.         
  25.         f = "": r = ""
  26.     Next X
  27.     Application.ScreenUpdating = True
  28. End Sub
複製代碼

TOP

軒云熊

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

回復 13# wei9133

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

zz1008.rar (53.2 KB)

TOP

軒云熊

帖子
253 
主題
5 
精華
0 
積分
308 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-3-20 
6#
發表於 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

軒云熊

帖子
253 
主題
5 
精華
0 
積分
308 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-3-20 
7#
發表於 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

軒云熊

帖子
253 
主題
5 
精華
0 
積分
308 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-3-20 
8#
發表於 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

軒云熊

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

回復 23# wei9133

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

javascript:;

1016.png (19.96 KB)

1016.png

TOP

軒云熊

帖子
253 
主題
5 
精華
0 
積分
308 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-3-20 
10#
發表於 2020-10-19 00:22 | 顯示全部帖子
回復 26# wei9133

有空看一下 不知道是不是你要的  

javascript:;

對戰統計 - 複製1019.rar (23.49 KB)

TOP

        靜思自在 : 人的心地是一畦田，土地沒有播下好種子，也長不出好的果實。 -
123
返回列表 上一主題