jcchiang

回復 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
如要改放於其他位置或做法,程式中都有註解,請自行微調,謝謝!!

軒云熊

回復 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

wei9133

回復 31# jcchiang

30F的確是我算錯了
力量英雄應該是4

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

第二段的部分你的理解是對的

勝場(3,空,1)=6,如果以空為1,實際也是5,多的1場不就是而外增加的嗎??
這個其實我沒看懂

我這樣看你能不能理解
紀錄出來的當列，本身就代表那次的勝場，當我統計到一模一樣的對戰，就在勝場處+1
所以每一列都代表了1，而勝場是另外加上去的，才會變成處理到該格若該格有值要+1上去
勝率那格若無另外的數值，整列視為1

===================分隔線======================
我拿了你在28F提供的程式碼下去執行
圖1

下載 (16.24 KB)

2020-10-22 06:22

圖一的第一跟第二列勝率欄位都是0，代表各自當列的勝場，而這兩個結構都一樣
所以運行出來應該是
合併起來，勝率寫1  (實際上是贏2場沒錯，但自己這一列就代表了一場，所以勝率那格只會寫1)
第三行是獨自自己一個，沒有相同列，所以就只有保留，至於勝率因為該格是0，且只有它自己，所以應該留空
我想執行出來的結果
圖2

下載 (32.4 KB)

2020-10-22 06:22

===============================================
實際執行出來的結果
圖3

下載 (33.34 KB)

2020-10-22 06:22

我執行的結果出來感覺是，勝率那格無論是空還是1都會被視為1
但實際上應該是該列等於1，勝率那格若有數字，
且該列要被併到另一列的話，就要以該格數字加上自己這一列代表的1

而是勝率那格是空值且無相同列可合併的，保留該列，勝率那格也就還是0
(因為贏的依舊只有一場，而那場就是該列本身)

==============================================
若這樣真的很難被理解的話，我可以改變統計方式
整列不代表任何數字，贏的次數全寫在勝率那裏
這個組合贏一次就寫1，贏兩次就寫2
這樣就不會有要計算本身列為1的問題了

你的整個程式我再研究看看要改哪裡才會符合我的需求
感謝兩位

wei9133

回復  wei9133

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

Sub ex3()
Dim d As Ob ...
軒云熊 發表於 2020-10-21 21:56

你好
因為測試完
勝率那格無論是空還是1都會被視為1，但實際上應該是空為1，寫1實際應為2 (要被合併的狀況下)
而不被合併的狀況下空就是空，該格不應有值 (因為該列自己就是1)
所以只註解掉迴圈加1的部分還是沒用的
勝率那格有值的正確了，空的就會有問題，反之亦然
所以你改的這樣還是不太對
感謝你了

jcchiang

回復 33# wei9133

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

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

jcchiang

回復 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

准提部林

組合1--a/b/d/f/h-人類(勝方)   組合2--b/d/e/f/g-人類(敗方) --- 共出現5次
組合2--b/d/e/f/g-人類(勝方)   組合1--a/b/d/f/h-人類(敗方) --- 共出現3次
雖然左右對調, 但應算同一組合對戰吧!

組合1--a/b/d/f/h-人類 -- 勝5敗3
組合2--b/d/e/f/g-人類 -- 勝3敗5

這勝敗率如何計算???

軒云熊

回復 34# wei9133

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

軒云熊

回復 34# wei9133

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

javascript:;

軒云熊

回復 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

複製代碼