軒云熊

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

複製代碼

軒云熊

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

複製代碼

wei9133

回復 22# 軒云熊

你好，因為後面這個已經變成比對了，所以跟一開始的作法已經不一樣
然後這兩天又增加新英雄，所以格子又不一樣了..

而比對的部分因為後面還加上整合成一行的部分
那就又必須考慮到幾個條件
1.A~CX(敗勝雙方出陣) & DB(星象)長的一模一樣的列
2.有些比較常出現的組合會有暫存的篩選快捷，裡面也有值的
  具體是CZ(備註)DC跟DE有雙方出陣的簡寫方便篩選後快速辨識
  (看不懂的話執行 "Sub 暫存篩選()"快捷鍵 ctrl+L，會比較好理解)
  或著這樣講判斷 上面這三個其中一個有值的，合併的基本就是它，把其他的勝敗場都加到這一列上面
  
3.所以是把符合"條件一"的列去比對，全部加在符合"條件二"的列上面，然後把該列的勝敗場都加起來填在各自的勝敗場
  要被合併的勝場該欄位數字要加1，因為出現這一列本身就是勝了一場，多勝一場才會在在勝場數上加上數字
  而敗場則否
  譬如
  共有三列符合上述所有條件 A~CX相同、DB相同
  而勝場部份的值則分別為3、空格、1，敗場的值則為1、空格、空格
  算出來合併的勝場欄位應為"6"，敗場則為"1"
  算法是這樣的，假設3那格保留，而空格代表勝1場，勝場填入1的實際上是"當列"加"勝1場"
  所以加出來是"6"

https://mega.nz/file/7dQmCLjI#QCQsI9fga6rZlsXJYLfrfaGz2ZUVmFLaCXtTOLFNvqI
我直接附上檔案，你用此檔案測試即可，有原始檔案也有助於你理解我說的到底是甚麼
當然如果有更好的方法也請提出
至於如果有幸有寫出vba程式碼的話
煩請直接回覆於帖子之中
(因為後續還會有新英雄加入，所以麻煩幫我註解若格子往後推的話要改哪個地方)


上面檔案中已有巨集，如有疑慮可以不開啟
巨集功用分別為Module2 塗底色(格式化條件)
Module1 篩選(V|W|空格|非空格|取消篩選)/字型顏色加粗

P.S.要注意版本用的是EXCEL 2003，我不清楚VBA的版本是否通用。

jcchiang

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

軒云熊

回復 23# wei9133

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

javascript:;

wei9133

回復 24# jcchiang

回復 24# jcchiang

兩位好
首先先感謝二位花時間幫我想辦法

至於空間的部分
我重新換個空間
googl
https://drive.google.com/file/d/1VFZMILovCRpQT6AGyaAd8ZNb9VAZSFlO/view?usp=sharing
onedrive
https://1drv.ms/u/s!Amaq2OY73W7WiSHXDt88TA7rsUgC?e=BmwuJh

附件:我有砍東西因為論壇只給1MB，不過用來理解需求應該夠
對戰統計 - 複製.rar (666.38 KB)

下載次數: 13

2020-10-18 02:15

1. Sub ex3()
   
2. Dim d As Object, ar As Object, r As Object
   
3. Dim i%, AA$, a
   
4. 
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set ar = [A1].CurrentRegion
   
7. 
   
8. For i = 1 To ar.Rows.Count
   
9.    AA = Join(Application.Transpose(Application.Transpose(ar(i, 1).Resize(, 102))), ",") & "," & ar(i, 106) '建立判斷條件
   
10.    If ar(i, 103) = "" Then ar(i, 103) = 1 '勝場空白填入1
    
11.    If Not d.exists(AA) Then   '字典內查無該條件
    
12.       d(AA) = ar(i, 1).Resize(, 106) '增加字典資料
    
13.    Else
    
14.       a = Application.Transpose(Application.Transpose(d(AA)))   '將字典資料取出
    
15.       a(103) = a(103) + ar(i, 103) '勝率累加
    
16.       a(104) = a(104) + 1           '備註:相符的筆數(不包含第一筆)
    
17.       a(105) = a(105) + ar(i, 105) '敗局累加
    
18.       d(AA) = a   '將資料放回字典
    
19.    End If
    
20. Next
    
21. [a14000].Resize(d.Count, 106) = Application.Transpose(Application.Transpose(d.items)) '將字典資料列出
    
22. For Each r In Range([cw14001], [cw14001].End(4))  '保留勝場+1
    
23.    r.Value = r.Value + 1
    
24. Next
    
25. Set d = Nothing
    
26. End Sub

複製代碼

因為加了新英雄所以位置不一樣了
我把程式的數字都往後推，但是看起來是有問題的
應該是因為前面的沒有給圖所以這裡會有問題
(勝跟敗中間有一個備註欄位)

下載 (25.2 KB)

2020-10-18 01:29

下載 (19.85 KB)

2020-10-18 01:29

下載 (14.85 KB)

2020-10-18 01:29

加總後應該優先填在這種列上 DC OR DE OR DK有值 其次是CZ有值

P.S.
在把數值加上去之前有讓程式跑過一遍
不過跟預計的一樣，格子不對所以是有問題的
但發現有幾個想問問可否變更的部分
其一
目前資料已有九千多行，所以其實比對出來資料是否正確我也無法驗證
所以可否將運行完成後的直接產生另一個活頁簿，我直接看兩個活業簿的列數是否有差異
(當然初始驗證運作的時候可以先把固定的資料複製多行再到產生的活頁簿去看相同列是否有加總上去就知道了)
ex.
原始資料(sheet1)9000行，產生的新活頁簿(sheet2)(比對過的資料)，變成8800，這樣就可以知道確實有疊上去了
再人工去確認sheet1跟sheet2的差異點就可以確認程式是否正確

其二
執行的時候是否可加上
Application.Calculation = xlCalculationManual '關閉自動計算
Application.ScreenUpdating = False '關閉螢幕刷新
全部結束後再加上
Application.Calculation = xlCalculationAutomatic '開啟自動計算
Application.ScreenUpdating = True '開啟螢幕刷新
避免程式一直重新計算儲存格?
(我目前無法測，因為我也不知道目前的程式到底對不對)

to 軒云熊
抱歉之前我沒自己下回來測過，這次我有下回來測過了，應該可以用了
p.s. 無法解壓也有可能是因為rar版本過舊，可以試看看新版的rar，目前個人版是免費的。

真的沒法下載的話，我把第一列都拍下來了

下載 (23.27 KB)

2020-10-18 01:55

下載 (21.48 KB)

2020-10-18 01:55

下載 (17.54 KB)

2020-10-18 01:55

目前是比對A~CX and DB長一樣
把上述條件一樣的列的CY(勝場) | DA(敗場)  加總填入同一列
至於填入哪一列優先考慮   DC OR DE OR DK有值 其次是CZ有值

下載 (41.06 KB)

2020-10-18 02:13

jcchiang所理解的條件是對的

軒云熊

回復 26# wei9133

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

javascript:;

jcchiang

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

wei9133

回復 28# jcchiang

你好
先以5格為基準直接執行
經測試，勝率部分不管有沒有重複都會直接+1上去
圖一

下載 (7.95 KB)

2020-10-20 22:59

(原始資料)
圖二

下載 (11.71 KB)

2020-10-20 22:59

(產出資料)

勝率這格有問題的樣子
我總共以5格做測試，1~5格複製一份放在下面列中，僅更改星象部分
出來結果是錯誤的
圖三

下載 (16.28 KB)

2020-10-20 22:59

(原始資料)
圖四

下載 (14.74 KB)

2020-10-20 22:59

(產出資料)

正確應該為
圖5

下載 (48.71 KB)

2020-10-20 22:59

另外，之前要修正後資料放進sheet2內本來就是為了比對程式是否執行正確
這次也是多虧了這點才能看出加總的部分不對
而我的第二位置活頁簿其實是有其他資料的，這樣就直接把資料全蓋過去了
可以麻煩改成複製一份當前(sheet)執行程式的副本，然後直接在執行活頁簿中將重複列刪除加總?
(建立副本作為備份，直接在需要運行的活頁簿內做刪除，若無法
我想到的是執行後把目前的sheet1刪除，sheet2改名成sheet1而已)

複製副本的指令可以的話幫我加註解，確認程式都正常運行之後就不需要做副本了
因為副本本來就是為了驗證是否正確執行而存在的
感謝

wei9133

回復 27# 軒云熊
你好
直接執行你的附件，勝率的確會增加
以刪除下面幾行，僅複製2~3行做副本，貼在5~6行
執行不會運作(懷疑是因為我空行了)
圖1

下載 (57.93 KB)

2020-10-20 23:19

並且在你初始的檔案中，執行後並未合併，而是直接加上勝率(場)

圖2

下載 (57.51 KB)

2020-10-20 23:19

初始

圖3

下載 (59.4 KB)

2020-10-20 23:19

執行後

正確應該是
圖4

下載 (33.57 KB)

2020-10-20 23:19