[發問] 搜尋前3大&amp;前3小值。

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-12-18

2^#

發表於 2021-9-6 12:15 | 只看該作者

回復 1# ziv976688

搜尋D欄和E欄之單欄的前3大的數值和前3小的數值，並以同列的B欄值，對應Sheets("Sheet1").[C1:AY1]的同值，
>> 新增紅字如下，請試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Dim Ar2(), Drr(1 To 16, 1 To 49), R%, K%
...
...
For i = 1 To n          '開啟Ar，找檔名有"統"裝入Ar1
Set f = fs.GetFolder(Ar(i, 1))
Set fc = f.Files
For Each f1 In fc
      If InStr(f1.Path, "統") Then
         ReDim Preserve Ar1(n1)
         Ar1(n1) = f1.Path
         n1 = n1 + 1
      End If
Next f1
Next i

fileOrg = ActiveWorkbook.Name
If n1 > 0 Then
R = 33
表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
               "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
For i1 = 0 To n - 1 '開啟Ar1
      Set WB = Workbooks.Open(Ar1(i1))
      fn = Split(Ar1(i1), "_")(5)
      With Sheets(1)
         If .FilterMode Then .ShowAllData
         With .Range(.[B1], .[E65536].End(3))
            Crr = .Value
            .Sort Key1:=.Item(3), Order1:=2, Header:=1
            Arr = .Value
            .Value = Crr
         End With
      End With
      WB.Close
      For i = 2 To 4  '前3數值
         ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
      Next
      For i = UBound(Arr) To 48 Step -1 '最後3數值
         ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
      Next
      For i = 0 To UBound(Ar2)
         T = Ar2(i)
         If i < 3 Then
            Drr(i + 1, T) = "V": Drr(i + 9, T) = "V"
         Else
            Drr(i + 2, T) = "V": Drr(i + 10, T) = "V"
         End If
      Next
      With Sheets("Sheet1")
         .Range("a" & R) = fn
         .Range("b" & R).Resize(16) = Application.Transpose(表頭)
         .Range("c" & R + 1).Resize(15, 49) = Drr
         R = .[b65536].End(3).Row + 1
      End With
      Erase Ar2: Erase Drr: K = 0
Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
...
...

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

3^#

發表於 2021-9-6 14:14 | 只看該作者

本帖最後由 ziv976688 於 2021-9-6 14:27 編輯

回復 2# samwang
謝謝您的再次指導。
測試結果 :
１＿少了1列間隔空白列~
EX；
Ａ４９＝１８８２，Ｂ４９：Ｂ６４＝表頭
正確為：
Ａ５０＝１８８２，Ｂ５０：Ｂ６５＝表頭

Ａ６５＝１８８１，Ｂ６５：Ｂ８０＝表頭
正確為：
Ａ６７＝１８８１，Ｂ６７：Ｂ８２＝表頭

Ａ８１＝１８８０，Ｂ８１：Ｂ９６＝表頭
正確為：
Ａ８４＝１８８０，Ｂ８４：Ｂ９９＝表頭

其餘．．．類推

２＿Ｖ的總數量目前是５８個（正確是６０個）～5期*2欄*(前3大+前3小)>=60~
但這個等上項列數調整後，小弟再測試結果～如真有誤時，再勞煩您修正。
謝謝您

7前3大&小_0_1884期_5期_1次.rar (15.68 KB)

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-12-18

4^#

發表於 2021-9-6 15:20 | 只看該作者

回復 3# ziv976688

１＿少了1列間隔空白列~
>> 更改如下紅字，謝謝

With Sheets("Sheet1")
         .Range("a" & R) = fn
         .Range("b" & R).Resize(16) = Application.Transpose(表頭)
         .Range("c" & R + 1).Resize(15, 49) = Drr
         R = .[b65536].End(3).Row + 2
End With

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

5^#

發表於 2021-9-6 18:33 | 只看該作者

回復 4# samwang
謝謝您的賜正。
打"V"的部分~我的效果檔範例也有筆漏~請在AP91填入"V"。謝謝!

打"V"部分的測試結果 :
1882；1881；1879~OK

1883~請修正下列儲存格~
AP47=""；AR47=V
AP48=V；AR48=""
詳如 :7統_0_1884期_1883_名次比對用

1880~請修正下列儲存格~
W91=V
AP48=V；AR48=""
W99=V；AP99=""
詳如 :7統_0_1884期_1880_名次比對用

PS :
1_COUNTIF(C34:AY116,"V")=61個
2_BUG都是發生在D和E二欄的同名次不是同一列和同名次有2個(含)以上時~
請問 : D欄和E欄的名次是否有分別統計?

以上懇請賜正。謝謝您^^

0906.rar (59.63 KB)

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-12-18

6^#

發表於 2021-9-6 21:35 | 只看該作者

本帖最後由 samwang 於 2021-9-6 21:45 編輯

回復 5# ziv976688

1883~請修正下列儲存格~
AP47=""；AR47=V
AP48=V；AR48=""
詳如 :7統_0_1884期_1883_名次比對用
>> 請忽略#2程式碼，已重新更新如下紅字，請再測試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Dim Ar2(), Drr(1 To 16, 1 To 49), Arr1,R%, K%, CR%, R1%
...
...
fileOrg = ActiveWorkbook.Name
If n1 > 0 Then
R = 33
表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
               "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
For i1 = 0 To n - 1 '開啟Ar1
      Set WB = Workbooks.Open(Ar1(i1))
      fn = Split(Ar1(i1), "_")(5)
      With Sheets(1)
         If .FilterMode Then .ShowAllData
         With .Range(.[B1], .[E65536].End(3))
            Crr = .Value
            .Sort Key1:=.Item(3), Order1:=2, Header:=1
            Arr = .Value '總次數
            .Sort Key1:=.Item(4), Order1:=1, Header:=1
            Arr1 = .Value '倍數
            .Value = Crr
         End With
      End With
      WB.Close
      For i = 2 To 4                   '總次數:最大3數值
         ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
      Next
      For i = UBound(Arr) To 48 Step -1 '總次數:最小3數值
         ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
      Next
      For i = UBound(Arr1) To 48 Step -1  '倍數:最大3數值
         ReDim Preserve Ar2(K): Ar2(K) = Arr1(i, 1): K = K + 1
      Next
      For i = 2 To 4                   '倍數:最小3數值
         ReDim Preserve Ar2(K): Ar2(K) = Arr1(i, 1): K = K + 1
      Next
      For i = 0 To UBound(Ar2)
         T = Ar2(i)
         If CR = 3 Then CR = 0: R1 = R1 + 2 Else R1 = R1 + 1
         Drr(R1, T) = "V": CR = CR + 1
      Next
      With Sheets("Sheet1")
         .Range("a" & R) = fn
         .Range("b" & R).Resize(16) = Application.Transpose(表頭)
         .Range("c" & R + 1).Resize(15, 49) = Drr
         R = .[b65536].End(3).Row + 2
      End With
      Erase Ar2: Erase Drr: K = 0: CR = 0: R1 = 0
Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
...
...

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

7^#

發表於 2021-9-6 22:36 | 只看該作者

本帖最後由 ziv976688 於 2021-9-6 22:54 編輯

回復 6# samwang
謝謝您的賜正

測試結果 :
不好意思，尚有一處有遺漏~
1880~
總次數的三小有2個~21和40(中式排名~"同名次" >=1個時，都要記錄)
W91 沒有記錄到
所以~
W91=V
懇請您賜正。
謝謝您

7前3大&小_0_1884期_5期_1次_W91.rar (13.12 KB)

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-12-18

8^#

發表於 2021-9-7 10:06 | 只看該作者

回復 7# ziv976688

不好意思，沒有想到這麼複雜，那就只能每次大小分開計算，因為每組大小裡面的數據都有可能重複且可能n筆重複資料，對吧?

例如: 總次數最大數值，數值: 21(最大)、40(2st)、41(2st)、42(3st) 或 21(最大)、40(2st)、41(3st)、42(3st) 或 ....

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

9^#

發表於 2021-9-7 10:34 | 只看該作者

本帖最後由 ziv976688 於 2021-9-7 10:51 編輯

回復 8# samwang
您太客氣了!您已經幫我很多忙了~謝謝您

不是說"教學相長"嗎?
我們都耐心等等~
看還有沒有其他高手願意幫忙和指導。

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-12-18

10^#

發表於 2021-9-7 11:29 | 只看該作者

回復 7# ziv976688

總次數的三小有2個~21和40(中式排名~"同名次" >=1個時，都要記錄)
W91  沒有記錄到
>> 因為前3大小有重複值，所以分開統計比對資料，更新如下，請再測試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Dim Drr(1 To 3, 1 To 49), Arr1, R%, K21%, K22%, K31%, K32%, R21%, R22%, R31%, R32%, T1%
Dim Ar21(1 To 10, 1 To 2), Ar22(1 To 10, 1 To 2), Ar31(1 To 10, 1 To 2), Ar32(1 To 10, 1 To 2)
Set xD = CreateObject("Scripting.Dictionary")
...
...
If n1 > 0 Then
R = 33
   表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
               "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
   For i1 = 0 To n - 1 '開啟Ar1
      Set WB = Workbooks.Open(Ar1(i1))
      fn = Split(Ar1(i1), "_")(5)
      With Sheets(1)
         If .FilterMode Then .ShowAllData
         With .Range(.[B1], .[E65536].End(3))
               Crr = .Value
               .Sort Key1:=.Item(3), Order1:=2, Header:=1
               Arr = .Value '總次數
            .Sort Key1:=.Item(4), Order1:=2, Header:=1
               Arr1 = .Value '倍數
            .Value = Crr
         End With
      End With
      WB.Close
      For i = 2 To UBound(Arr)          '總次數:最大3數值
         K21 = K21 + 1: If K21 > 3 And xD(Arr(i, 3) & "_21") <> 1 Then Exit For
         Ar21(K21, 1) = Arr(i, 1): Ar21(K21, 2) = Arr(i, 3): xD(Arr(i, 3) & "_21") = 1
      Next
      For i = UBound(Arr) To 2 Step -1 '總次數:最小3數值
         K22 = K22 + 1: If K22 > 3 And xD(Arr(i, 3) & "_22") <> 1 Then Exit For
         Ar22(K22, 1) = Arr(i, 1): Ar22(K22, 2) = Arr(i, 3): xD(Arr(i, 3) & "_22") = 1
      Next
      For i = 2 To UBound(Arr1)       '倍數:最大3數值
         K31 = K31 + 1: If K31 > 3 And xD(Arr1(i, 4) & "_31") <> 1 Then Exit For
         Ar31(K31, 1) = Arr1(i, 1): Ar31(K31, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "_31") = 1
      Next
      For i = UBound(Arr1) To 2 Step -1 '倍數:最小3數值
         K32 = K32 + 1: If K32 > 3 And xD(Arr1(i, 4) & "_32") <> 1 Then Exit For
         Ar32(K32, 1) = Arr1(i, 1): Ar32(K32, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "_32") = 1
      Next

      With Sheets("Sheet1")
         .Range("a" & R) = fn
         .Range("b" & R).Resize(16) = Application.Transpose(表頭)
         For i = 1 To K21 - 1  '總次數:最大3數值
            T = Ar21(i, 2): If T1 = T Then R21 = R21 Else R21 = R21 + 1
            Drr(R21, Ar21(i, 1)) = "V": T1 = T
         Next
         .Range("c" & R + 1).Resize(3, 49) = Drr
         R = .[b65536].End(3).Row - 10: Erase Drr: T1 = 0
         For i = 1 To K22 - 1  '總次數:最小3數值
            T = Ar22(i, 2): If T1 = T Then R22 = R22 Else R22 = R22 + 1
            Drr(R22, Ar22(i, 1)) = "V": T1 = T
         Next
         .Range("c" & R).Resize(3, 49) = Drr
         R = .[b65536].End(3).Row - 6: Erase Drr: T1 = 0

         For i = 1 To K31 - 1  '倍數:最大3數值
            T = Ar31(i, 2): If T1 = T Then R31 = R31 Else R31 = R31 + 1
            Drr(R31, Ar31(i, 1)) = "V": T1 = T: T1 = 0
         Next
         .Range("c" & R).Resize(3, 49) = Drr
         R = .[b65536].End(3).Row - 2: Erase Drr: T1 = 0
         For i = 1 To K32 - 1  '倍數:最小3數值
            T = Ar32(i, 2): If T1 = T Then R32 = R32 Else R32 = R32 + 1
            Drr(R32, Ar32(i, 1)) = "V": T1 = T: T1 = 0
         Next
         .Range("c" & R).Resize(3, 49) = Drr
         R = .[b65536].End(3).Row + 2: Erase Drr: T1 = 0
      End With
      Erase Ar21: Erase Ar22: Erase Ar31: Erase Ar32: xD.RemoveAll
      K21 = 0: K22 = 0: K31 = 0: K32 = 0: R21 = 0: R22 = 0: R31 = 0: R32 = 0
   Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
...
...