vba的篩選功能 (取消部分篩選) - Excel程式區

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

1^# 跳轉到 »

發表於 2020-10-8 09:04 | 顯示全部帖子

回復 13# wei9133

樓主需求的篩選模式在同一sheet是無法執行的(ikboy已經說明了)
如果只是要計算各星象勝率/敗局建議可用比對的
只是無法看出這2各區塊(A~AW)內資料的相關性&勝率/敗局計算方式??

TOP

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

2^#

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

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

3^#

發表於 2020-10-19 10:23 | 顯示全部帖子

回復 26# wei9133

資料改放置於第二個Sheet
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("對戰統計").[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

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

4^#

發表於 2020-10-21 08:26 | 顯示全部帖子

回復 29# wei9133

勝率計算是否為沒有重複的就不多加1場嗎??
因為你的勝場算法都不一樣
以你在#30樓的貼圖
人類4場勝率為(1,2,空,空),勝率應為1+2+1+1=5保留再加1,所以為6
但力量英雄2場勝率為(空,3),勝率應為1+3=4保留再加1,所以為5,但給的正確勝率卻為3

(#23樓:而勝場部份的值則分別為3、空格、1，敗場的值則為1、空格、空格
算出來合併的勝場欄位應為"6"，敗場則為"1"
算法是這樣的，假設3那格保留，而空格代表勝1場，勝場填入1的實際上是"當列"加"勝1場"
所以加出來是"6")
勝場(3,空,1)=6,如果以空為1,實際也是5,多的1場不就是而外增加的嗎??

另外資料放置其他Sheet是不去改變原有資料以便驗證,而且程式註解也有寫放置於第二個Sheet
如要改放於其他位置或做法,程式中都有註解,請自行微調,謝謝!!

TOP

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

5^#

發表於 2020-10-22 08:22 | 顯示全部帖子

回復 33# wei9133

#33
有2場一樣(勝率欄為"空","空")合併勝率為1
只有1場(勝率欄為"空")勝率為"空"

幾種狀況如何計算
2場(勝率為"3","空")合併勝率??(是否為4)
3場(勝率為"3","空","空")合併勝率??(是否為4)
3場(勝率為"空","空","空")合併勝率??(是否為1)
3場(勝率為"3","1","空")合併勝率??(是否為5)
4場(勝率為"空","3","1","空")合併勝率??(是否為5)
只有一場是否勝率欄位都不變
多場的只要勝率為空的不管幾場都只算1場勝場,其餘勝率欄有值的直接累加值

TOP

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

6^#

發表於 2020-10-22 10:24 | 顯示全部帖子

回復 33# wei9133

1.資料位置放置第二個sheet,請自行修改放置位置
2.勝場計算方式
-->只有1筆資料,勝場都不變動
-->2筆以上資料,所有的"空"都算增加1場,有值的直接累加

Sub ex4()
Dim d As Object, ar As Object, r
Dim i%, AA$, a
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set ar = Sheets("對戰統計").[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)))
   ReDim Preserve a(1 To UBound(a) + 2)
   If a(103) = "" Then a(UBound(a) - 1) = 1 '紀錄勝場空白數
   a(UBound(a)) = 1 '紀錄筆數
   d(AA) = a '將資料放回字典
Else
   a = Application.Transpose(Application.Transpose(d(AA))) '將字典資料取出
   If ar(i, 103) = "" Then a(UBound(a) - 1) = a(UBound(a) - 1) + 1 Else a(103) = a(103) + ar(i, 103) '勝場空白紀錄累加1,不是空白則將欄位值相加
   a(UBound(a)) = a(UBound(a)) + 1 ''紀錄筆數+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, UBound(a)) = Application.Transpose(Application.Transpose(d.items)) '將字典資料列出
For Each r In .Range(.[cy2], .[cy65535].End(3))
If r.Offset(, 14) > 1 And r.Offset(, 13) > 0 Then r.Value = r.Value + 1 '2筆資料以上且有勝場為"空"的勝場+1
Next
i = .[a1].CurrentRegion.Columns.Count
.Range(Cells(1, i - 1), Cells(65535, i).End(3)).Clear '清除空白&資料計算筆數
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub

TOP

jcchiang

中學生 Rank: 2

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

7^#

發表於 2020-10-29 11:30 | 顯示全部帖子

本帖最後由 jcchiang 於 2020-10-29 11:31 編輯

回復 44# wei9133

1.那段程式我執行沒有問題(只是清除計數資料,新的程式已不需要)
2.只要是只有1列的維持原資料
第二列開始,除勝率欄位數值累加,每列再加1(第一列不加)
僅1列無其他相同者 (該格勝率為 "3")
總共勝4場，合併後勝率欄標記為 3場
-->1列的維持原資料

僅1列無其他相同者 (該格勝率為 "空")
總共勝1場，合併後勝率欄標記為空場
-->1列的維持原資料

共2列相同勝率為 "2","空"
總共勝4場，合併後勝率欄標記為 3場
-->2列以上("2"+"(0+1)"=3)

共2列相同勝率為 "空","空"
總共勝2場，合併後勝率欄標記為 1場
-->2列以上("0"+"(0+1)"=1)

共2列相同勝率為 "2","1"
總共勝5場，合併後勝率欄標記為 4場
-->2列以上("2"+"(1+1)"=4)

共3列相同勝率為 "2","空","1"
總共勝6場，合併後勝率欄標記為 5場
-->2列以上("2"+"(0+1)","(1+1)"=5)

共4列相同勝率為 "7","空","3","空"
總共勝14場，合併後勝率欄標記為 13場
-->2列以上("7"+"(0+1)"+"(3+1)"+"(0+1)"=13)
如果還是不對,請寫計算公式(只寫幾場很難理解)

Sub ex5()
Dim d As Object, ar As Object, r
Dim i%, AA$, a
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set ar = Sheets("對戰統計").[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 '字典內查無該條件
   d(AA) = Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 115)))
Else
   a = Application.Transpose(Application.Transpose(d(AA))) '將字典資料取出
   a(103) = a(103) + ar(i, 103) + 1 '第二筆以上勝場都多加1
   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, UBound(a)) = Application.Transpose(Application.Transpose(d.items)) '將字典資料列出
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub

TOP

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

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]