麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 指定號碼在偶數欄的總個數及奇數欄的總次數 [打印本頁]

作者: ziv976688 時間: 2021-8-19 10:01 標題: 指定號碼在偶數欄的總個數及奇數欄的總次數

[attach]33910[/attach]
C2= (M$2︰DF$50)的偶數欄=B2的總個數
C3= (M$2︰DF$50)的偶數欄=B3的總個數
︰
︰
C50= (M$2︰DF$50)的偶數欄=B50的總個數

D2= (M$2︰DF$50)的偶數欄=B2之奇數欄總次數
D3= (M$2︰DF$50)的偶數欄=B3之奇數欄總次數
︰
︰
D50= (M$2︰DF$50)的偶數欄=B50之奇數欄總次數

請問︰
C2的函數公式 ?
D2的函數公式 ?
謝謝 !

作者: ML089 時間: 2021-8-19 10:53

C2 =COUNT(0/((B2=M$2:DE$99)*MOD(COLUMN(M:DE),2)))
D2 =SUM((B2=M$2:DE$99)*MOD(COLUMN(M:DE),2)*N$2:DF$99)

作者: samwang 時間: 2021-8-19 12:39

回復 1# ziv976688

Sub test()
Dim Arr, xD, T%, i&, j&, Tm
Tm = Timer
Set xD = CreateObject("Scripting.Dictionary")
R = Columns("M:DF").Find("*", , , , , 2).Row
Arr = Range("M1:DF" & R)
For j = 1 To UBound(Arr, 2) Step 2
For i = 2 To UBound(Arr)
      T = Arr(i, j): If T = 0 Then GoTo 98
      xD(T & "/1") = xD(T & "/1") + 1
      xD(T & "/2") = xD(T & "/2") + Arr(i, j + 1)
Next i
98: Next j
Arr = Range([C1], [B65536].End(3))
For i = 2 To UBound(Arr)
For j = 1 To 2: Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j): Next
Next
[c2].Resize(UBound(Arr) - 1, 2) = Arr
MsgBox Timer - Tm
End Sub

作者: ziv976688 時間: 2021-8-19 13:00

回復 2# ML089
版主大大:
謝謝您的指導和幫忙~感恩

作者: ziv976688 時間: 2021-8-19 13:01

回復 3# samwang
S大大:
謝謝您的指導和幫忙~感恩

作者: ziv976688 時間: 2021-8-20 05:49

回復 3# samwang
S大大:您好!
不好意思~有點小問題~敬請賜正~謝謝

[attach]33921[/attach]
[attach]33922[/attach]

作者: samwang 時間: 2021-8-20 07:51

回復 6# ziv976688

你的B欄的數字1~49 不見了，所以導致那個問題，謝謝

作者: ziv976688 時間: 2021-8-20 08:35

回復 7# samwang
不好意思~我疏忽了

謝謝您

作者: ziv976688 時間: 2021-8-22 01:47

回復 2# ML089
回復 3# samwang
[attach]33934[/attach]

下列新增需求的語法~懇請二位大大繼續賜教。謝謝 !
.[A2] = ((M1:DF1)<>""的欄數)/2 & "個"   '列10
.[A4:A10] =當A$1<>""時，則顯示DATA!A欄=A$1期數之B:H號碼 '列12

'列32以下
.[E2:E50] =當D2>0時，則顯示D2/C2之值。
.[G2:G50] =.[C2:C50]的值~由大而小依序往下排列。
.[H2:H50] =將.[G2:G50] <>""的排名(可重複)依序往下排列。
.[I2:I50] =當.[G2:G50]中<>""的某值=.[C2:C50]的某值時，則顯示.[C2:C50]的該某值同列的B欄值。
.[J2:J50] =當.[I2:I50]中的某值=.[B2:B50]的某值時，則顯示.[B2:B50]的該某值同列的D欄值。
.[K2:K50] =當.[I2:I50]中的某值=.[B2:B50]的某值時，則顯示.[B2:B50]的該某值同列的E欄值。

作者: samwang 時間: 2021-8-22 08:30

回復 ML089
回復 samwang

下列新增需求的語法~懇請二位大大繼續賜教。謝謝 !
.[A2] = ((M1F1) ...
ziv976688 發表於 2021-8-22 01:47

請測試看看，謝謝
Sub test()
Dim Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Set xD = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
T = .[A1]
Arr = Range([DATA!h1], [DATA!a65536].End(3))
For i = 2 To UBound(Arr)
If Arr(i, 1) = T Then
For j = 2 To 8: n = n + 1: Brr(n) = Arr(i, j): Next
End If
Next
.[A4].Resize(7) = Application.Transpose(Brr)
.[A2] = (.Cells(1, 256).End(xlToLeft).Column - 12) / 2
Arr = .Range(.[B2], .[e65536].End(3))
ReDim Crr(1 To UBound(Arr), 1 To 5)
For i = 1 To UBound(Arr)
If Arr(i, 3) > 0 Then Arr(i, 4) = Arr(i, 3) / Arr(i, 2)
Crr(i, 1) = Arr(i, 2): Crr(i, 2) = Arr(i, 2)
Crr(i, 3) = Arr(i, 1): Crr(i, 4) = Arr(i, 3)
Crr(i, 5) = Arr(i, 4)
Next
.[B2].Resize(UBound(Arr), 4) = Arr
With Range("g2").Resize(UBound(Crr), 5)
.Value = Crr
.Sort key1:=.Item(1), Order1:=2, Header:=xlNo
Crr = .Value
End With
T = Application.Max(.Range("g2:g" & UBound(Crr)))
For i = 1 To UBound(Crr)
Crr(i, 1) = T - Crr(i, 1) + 1
Next
[H2].Resize(UBound(Crr), 1) = Crr
End With
End Sub

作者: samwang 時間: 2021-8-22 08:38

回復 9# ziv976688

請自行新增如下，因為當無資料補上0，謝謝

For i = 2 To UBound(Arr)
   For j = 1 To 2: Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j): Next
   If xD(Arr(i, 1) & "/1") = "" Then Arr(i - 1, 1) = 0: Arr(i - 1, 2) = 0 '要新增
Next
  .[C2].Resize(UBound(Arr) - 1, 2) = Arr  'C&D欄

作者: ziv976688 時間: 2021-8-22 10:28

本帖最後由 ziv976688 於 2021-8-22 10:40 編輯

回復 10# samwang
感謝您的指導^^

[attach]33936[/attach]
[attach]33937[/attach]
不好意思，"新增需求"的程式碼~我放置的位列~不知道是哪裡有誤置?
所以在列47會產生偵錯^^"
If Arr(i, 3) > 0 Then Arr(i, 4) = Arr(i, 3) / Arr(i, 2)
尚請勞駕您賜正。謝謝您!

Private Sub CommandButton1_Click()
Dim Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
Tm = Timer
[L1] = ""
Application.DisplayAlerts = False

Set xD = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
      .[A1] = Nrange
      T = .[A1]
      Arr = Range([DATA!h1], [DATA!a65536].End(3))
      For i = 2 To UBound(Arr)
      If Arr(i, 1) = T Then
      For j = 2 To 8: n = n + 1: Brr(n) = Arr(i, j): Next
      End If
      Next

   .[A2] = ((.Cells(1, 256).End(xlToLeft).Column - 12) / 2) & "個"
   .[A3] = "開獎號碼"
   .[A4].Resize(7) = Application.Transpose(Brr)

      For i = 1 To 49 'B欄
      .Range("B" & i + 1) = i
      Next

      R = .Columns("M:DF").Find("*", , , , , 2).Row
      Arr = .Range("M1:DF" & R)
   For j = 1 To UBound(Arr, 2) Step 2
   For i = 2 To UBound(Arr)
      T = Arr(i, j): If T = 0 Then GoTo 98
      xD(T & "/1") = xD(T & "/1") + 1
      xD(T & "/2") = xD(T & "/2") + Arr(i, j + 1)
   Next i
98: Next j
   Arr = .Range(.[C1], .[B65536].End(3))
   For i = 2 To UBound(Arr)
   For j = 1 To 2: Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j): Next
   If xD(Arr(i, 1) & "/1") = "" Then Arr(i - 1, 1) = 0: Arr(i - 1, 2) = 0 '要新增
   Next
   .[C2].Resize(UBound(Arr) - 1, 2) = Arr  'C&D欄

Arr = .Range(.[B2], .[e65536].End(3))
ReDim Crr(1 To UBound(Arr), 1 To 5)
For i = 1 To UBound(Arr)
If Arr(i, 3) > 0 Then Arr(i, 4) = Arr(i, 3) / Arr(i, 2)
Crr(i, 1) = Arr(i, 2): Crr(i, 2) = Arr(i, 2)
Crr(i, 3) = Arr(i, 1): Crr(i, 4) = Arr(i, 3)
Crr(i, 5) = Arr(i, 4)
Next
.[B2].Resize(UBound(Arr), 4) = Arr
With .Range("g2").Resize(UBound(Crr), 5)
.Value = Crr
.Sort key1:=.Item(1), Order1:=2, Header:=xlNo
Crr = .Value
End With
T = Application.Max(.Range("g2:g" & UBound(Crr)))
For i = 1 To UBound(Crr)
Crr(i, 1) = T - Crr(i, 1) + 1
Next
.[H2].Resize(UBound(Crr), 1) = Crr

'版面格式.........................................................
         With .Columns("A:DF")
            .Font.Name = "Verdana"  '字體
            .HorizontalAlignment = xlCenter  '左右置中
            .VerticalAlignment = xlCenter  '上下置中
            .EntireColumn.AutoFit  '自動欄寬
            .EntireRow.AutoFit  '自動列高
         End With
End With

      Sheets("Sheet1").Copy
      ActiveWorkbook.SaveAs ThisWorkbook.Path & "\7C_0_" & Nrange & "期_" & Sheets("Sheet1").[A2] & ".xls"
      ActiveWindow.Close
Application.Goto [DATA!J1]
[L1] = Nrange & "=" & Format((Timer - Tm) / 24 / 60 / 60, "hh:mm:ss")
End Sub

作者: samwang 時間: 2021-8-22 10:44

回復 samwang
感謝您的指導^^

不好意思，"新增需求"的程式碼~我放置的位列~不知道是哪裡有誤置 ...
ziv976688 發表於 2021-8-22 10:28

不好意思，Arr來源的資料b、e要對調一下即可，謝謝
Arr = .Range(.[e2], .[b65536].End(3))

作者: ziv976688 時間: 2021-8-22 12:22

回復 13# samwang
OK了

謝謝您多次的熱心幫忙和指導~感恩

作者: ziv976688 時間: 2021-8-22 14:31

本帖最後由 ziv976688 於 2021-8-22 14:34 編輯

回復 13# samwang
不好意思~懇請您再指導取代的語法：
將M:V = A4:A9且為7號字顏的數字~標示4號底色
將M:V = A10且為7號字顏的數字~標示8號底色
謝謝您！
[attach]33938[/attach]
[attach]33939[/attach]

作者: samwang 時間: 2021-8-22 15:41

回復 15# ziv976688

儲存格反顏色如下，請測試看看，謝謝

Sub test()
Dim Arr, Brr
With Sheets("Sheet1")
Arr = .[a1:a10]
R = .Columns("M:V").Find("*", , , , , 2).Row
Brr = .Range("M1:DF" & R)
For i = 4 To UBound(Arr)
      If i < UBound(Arr) Then
         .Cells(i, 1).Interior.Color = 65280
         For j = 1 To UBound(Brr, 2) Step 2
         For i2 = 2 To UBound(Brr)
            If Brr(i2, j) = Arr(i, 1) Then
            .Cells(i2, j + 12).Interior.Color = 65280
            End If
         Next i2
         Next j
      Else
         .Cells(i, 1).Interior.Color = 16776960
         For j = 1 To UBound(Brr, 2) Step 2
         For i2 = 2 To UBound(Brr)
            If Brr(i2, j) = Arr(i, 1) Then
            .Cells(i2, j + 12).Interior.Color = 16776960
            End If
         Next i2
         Next j
      End If
Next
End With
End Sub

作者: ziv976688 時間: 2021-8-22 22:12

回復 16# samwang
完全OK了!
感謝您

作者: ziv976688 時間: 2021-8-23 00:15

本帖最後由 ziv976688 於 2021-8-23 00:44 編輯

回復 16# samwang
S大大 : 您好 !
不好意思，能否請您另外再指導~以尋找→取代的方式來完成需求?
EX1：範圍 = .Columns("B:DF")，尋找 = .[A4:A9] 且字體顏色=7號的數字，取代為4號底色。
EX2：範圍 = .Columns("B:DF")，尋找 = .[A10] 且字體顏色=7號的數字，取代為8號底色。
恕小弟笨拙~當標示的範圍改變時，原程式碼的各關鍵數字~我無法調整到完全符合(總有衝突)需求的數字。
謝謝您！

======================================
如下列錄製以尋找和取代的方式之程式碼 :
With Sheets("Sheet1")
.Columns("B:DF").Select
With Application.FindFormat.Font
      .FontStyle = "粗體"
      .Subscript = False
      .ColorIndex = 7
End With
Application.ReplaceFormat.Interior.ColorIndex = 8
Selection.Replace What:=.[A10], Replacement:="", LookAt:=xlWhole, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=True, _
      ReplaceFormat:=True
End With

作者: samwang 時間: 2021-8-23 07:26

回復 samwang
S大大 : 您好 !
不好意思，能否請您另外再指導~以尋找→取代的方式來完成需求?
EX1：範圍 ...
ziv976688 發表於 2021-8-23 00:15

不太能理解您的意思，
尋找 = .[A4:A9] 且字體顏色=7號的數字，取代為4號底色 >> 這是不是和#16程式需求一樣嗎?

作者: ziv976688 時間: 2021-8-23 07:37

本帖最後由 ziv976688 於 2021-8-23 07:41 編輯

回復 19# samwang

不太能理解您的意思，
尋找 = .[A4:A9] 且字體顏色=7號的數字，取代為4號底色 >> 這是不是和#16程式需求一樣嗎?

是的! 謝謝您

-----------------
不好意思~
我只會最基本的 If..... Then......End If  的語法
EX :這個需求，我只會~
Sub test()
Dim i%, j%, k%

With Sheets("Sheet1")
For i = 4 To 9
  For j = 2 To 50
For k = 2 To 110
If Cells(j, k).Font.ColorIndex = 7 Then
   If (Cells(j, k) = Cells(i, 1)) Then
   Cells(j, k).Interior.ColorIndex = 4
   End If
   If (Cells(j, k) = Cells(10, 1)) Then
   Cells(j, k).Interior.ColorIndex = 8
   End If
End If
Next k
Next j
  Next i
End With
End Sub

因為很想學習貴語法，所以才冒昧一題勞煩您這麼多次~尚請見諒

謝謝您

作者: samwang 時間: 2021-8-23 07:45

回復 20# ziv976688

後學也是學習中，每個人寫法不一定都一樣，只要能寫出需求功能就好，感謝。

作者: ziv976688 時間: 2021-8-23 08:03

回復 21# samwang
我不是意在比較寫法~您可能誤會我的意思了

If..... Then......End If 只能用在單純的需求，
貴語法的適用範圍寬廣許多~所以才一再冒昧大擾您~尚請見諒

非常謝謝您耐心的指導和熱心幫忙~感恩

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)