[發問] 連續N筆資料判別

y54161212

我想寫一個判斷品質的程式
大概內容為將數值與中心值CL判斷
在C欄
> CL =1
<CL =0
用此C欄判斷
然後在
D欄位標註是否連續7筆資料都是>CL
E欄位判斷是否連續7筆都是都是<CL

=========================程式碼==================
Dim side%, QQ%, QQ1%, CL As Variant
k = Cells(Rows.Count, 1).End(xlUp).Row
CL = Range("C1").Value
Range("C3:E" & k).ClearContents


If CL <> "" And k - 1 > 0 Then
    For i = 3 To k
     
     If Range("A" & i) > CL Then
     Range("C" & i) = 1
     Else
     Range("C" & i) = 0
     End If
      
    Next
End If
'==判斷是否連續7筆大於或小於CL========
For i = 3 To k
        If (Range("C" & i) = 1 And Range("C" & i + 1) = 1 And Range("C" & i + 2) = 1 And Range("C" & i + 3) = 1 And Range("C" & i + 4) = 1 And Range("C" & i + 5) = 1 And Range("C" & i + 6) = 1) Then
        Range("D" & i + 6) = 1
        
        ElseIf (Range("C" & i) = 0 And Range("C" & i + 1) = 0 And Range("C" & i + 2) = 0 And Range("C" & i + 3) = 0 And Range("C" & i + 4) = 0 And Range("C" & i + 5) = 0 And Range("C" & i + 6) = 0) Then
        Range("E" & i + 6) = 1
    End If
Next


QQ = Application.WorksheetFunction.Sum(Range("D3:D" & k))
QQ1 = Application.WorksheetFunction.Sum(Range("E3:E" & k))

If QQ >= 1 Then
MsgBox "連續7點在中心線同側(大於)"
End If

If QQ1 >= 1 Then
MsgBox "連續7點在中心線同側(小於)"
End If

================================================================
我在想是否有更好的寫法用來判斷
連續7筆資料>CL或<CL

請求指導
謝謝各位先進

ikboy

1. Sub zz()
   
2. Dim a, cl, s$, b(1), k, aa(), n&, m&, r&
   
3. a = [a1].CurrentRegion.Resize(, 3)
   
4. cl = a(1, 3)
   
5. ReDim aa(1 To UBound(a) - 2, 1 To 3)
   
6. With CreateObject("vbscript.regexp")
   
7.     .Global = True
   
8.     For i = 3 To UBound(a)
   
9.         If a(i, 1) <= cl Then k = 0 Else k = 1
   
10.         aa(i - 2, 1) = k
    
11.         s = s & k
    
12.     Next
    
13.     n = Len(s)
    
14.     b(0) = "(1{7," & n & "})"
    
15.     b(1) = "(0{7," & n & "})"
    
16.     For j = 0 To 1
    
17.         .Pattern = b(j)
    
18.         s = .Replace(s, "|$1|")
    
19.     Next
    
20.     k = Split(s, "|")
    
21.     n = 0
    
22.     For Each t In k
    
23.         n = Len(t)
    
24.         If n Then
    
25.             If n > 6 Then
    
26.                 n = Left(t, 1)
    
27.                 r = r + 6
    
28.                 For i = 7 To Len(t)
    
29.                     r = r + 1
    
30.                     aa(r, 2 + n) = n
    
31.                 Next
    
32.             Else
    
33.                 r = r + Len(t)
    
34.             End If
    
35.         End If
    
36.     Next
    
37. End With
    
38. [c3].Resize(UBound(aa), 3) = aa
    
39. End Sub

複製代碼

n7822123

回復 1# y54161212



用 1 與 -1 程式會簡單點，1個迴圈即可搞定

以下 紅色程式 部分，只是列出判斷過程，可有可無

不影響跳品質異常提醒


Sub 判斷品質異常()
Const N = 7   '設定連續次數
Dim Rn&, R%, S%, T%, CL!
Dim 連續大 As Boolean, 連續小 As Boolean
Rn = Cells(Rows.Count, 1).End(xlUp).Row - 2
If Rn < 1 Then Exit Sub
CL = [C1]
With [A3].Resize(Rn, 5)
  Arr = .Value
  .ClearContents
End With
For R = 1 To Rn
  Arr(R, 3) = IIf(Arr(R, 1) > CL, 1, -1)
  S = S + Arr(R, 3)
  If S = N Then 連續大 = True: S = S - 1: Arr(R, 4) = 1
  If S = -N Then 連續小 = True: S = S + 1: Arr(R, 5) = 1
  If Arr(R, 3) <> T Then T = Arr(R, 3): S = T
Next R
[A3].Resize(Rn, 5) = Arr
If 連續大 Then MsgBox "連續7點在中心線同側(大於)"
If 連續小 Then MsgBox "連續7點在中心線同側(小於)"
End Sub

y54161212

上面兩位真的是太神了
我完全沒辦法吸收（笑
要好好讀一讀⋯半路踏進vba 還真多東西要問啊

ikboy

回顧2#代碼有誤,更正一下

1. Sub zz()
   
2. Dim a, CL, s$, k, t, aa(), n&, m&, r&, Msg(1)
   
3. a = [a1].CurrentRegion.Resize(, 3)
   
4. CL = a(1, 3)
   
5. ReDim aa(1 To UBound(a) - 2, 1 To 3)
   
6. With CreateObject("vbscript.regexp")
   
7.     .Global = True
   
8.     For i = 3 To UBound(a)
   
9.         If a(i, 1) <= CL Then k = 0 Else k = 1
   
10.         aa(i - 2, 1) = k
    
11.         s = s & k
    
12.     Next
    
13.     .Pattern = "(0{7,}|1{7,})"
    
14.     s = .Replace(s, "#$1|")
    
15.     k = Split(s, "#")
    
16.     For Each t In k
    
17.         m = InStr(t, "|")
    
18.         If m Then
    
19.             m = m - 1 + r
    
20.             n = Left(t, 1)
    
21.             Msg(n) = n
    
22.             i = r + 7
    
23.             For j = i To m
    
24.                 aa(j, 3 + -n) = 1
    
25.             Next
    
26.             r = Len(t) - 1
    
27.         Else
    
28.             r = r + Len(t)
    
29.         End If
    
30.     Next
    
31. End With
    
32. [c3].Resize(UBound(aa), 3) = aa
    
33. n = Len(Join(Msg, ""))
    
34. Select Case n
    
35.     Case 1
    
36.         MsgBox "連續" & Join(Msg, "") & "在中心線側"
    
37.     Case 2
    
38.         MsgBox "連續" & Join(Msg, "和") & "在中心線側"
    
39. End Select
    
40. End Sub

複製代碼

准提部林

Sub 判斷品質異常_A()
Dim Arr, Brr, R&, C%, N%(1), X%(1), i&, CL!
R = Cells(Rows.Count, 1).End(xlUp).Row - 2
If R < 1 Then Exit Sub
CL = [C1]
Arr = [A3].Resize(R)
ReDim Brr(1 To R, 1 To 4)
For i = 1 To R
    C = -(Arr(i, 1) > CL): Brr(i, 1) = C
    N(C) = N(C) + 1: N(1 - C) = 0
    If N(C) >= 7 Then Brr(i, 3 - C) = 1: X(C) = 1
Next i
[C3].Resize(R, 4) = Brr
If X(1) Then MsgBox "連續7點在中心線同側(大於)"
If X(0) Then MsgBox "連續7點在中心線同側(小於)"
End Sub


'================================

准提部林

D3//右拉/下拉
=IF(COUNTIF(OFFSET($A3,,,-MIN(ROW(A1),7)),IF(COLUMN(A1)=1,">","<=")&$C$1)>6,1,"")

n7822123

回復 4# y54161212

上面兩位真的是太神了
我完全沒辦法吸收（笑

我覺得我寫的很直覺阿，就判斷成1 , -1 在加總而已

ikboy 的正規表示法 我也不是很懂XD

你也可以參考準大的，他是用兩個變數分別加總　

N(1)紀錄大於CL次數
N(0)紀錄小於CL次數


j我的程式，如果要擴展到8次、9次，改N值即可

秀出的訊息沒改到，修改如下

Sub 判斷品質異常()
Const N = 7   '設定連續次數
Dim Rn&, R%, S%, T%, CL!
Dim 連續大 As Boolean, 連續小 As Boolean
Rn = Cells(Rows.Count, 1).End(xlUp).Row - 2
If Rn < 1 Then Exit Sub
CL = [C1]
With [A3].Resize(Rn, 5)
  Arr = .Value
  .ClearContents
End With
For R = 1 To Rn
  Arr(R, 3) = IIf(Arr(R, 1) > CL, 1, -1)
  S = S + Arr(R, 3)
  If S = N Then 連續大 = True: S = S - 1: Arr(R, 4) = 1
  If S = -N Then 連續小 = True: S = S + 1: Arr(R, 5) = 1
  If Arr(R, 3) <> T Then T = Arr(R, 3): S = T
Next R
[A3].Resize(Rn, 5) = Arr
If 連續大 Then MsgBox "連續" & N & "點在中心線同側(大於)"
If 連續小 Then MsgBox "連續" & N & "點在中心線同側(小於)"
End Sub

准提部林

回復 8# n7822123


With [A3].Resize(Rn, 5)
  Arr = .Value '五欄資料存入陣列
  .ClearContents '清除原有資料, 但原資料還在陣列中, 當陣列貼回時, 還會有殘留, 可修改a欄參數不更動其它列資料試試
End With

另外, 儘量不要清空原數據, 避免程式因錯誤中斷而遺失資料,
而且, 貼回時, 也應限制在變動區, 而避免全區貼回, 若資料龐大則須花費回寫填滿的時間


===============================

n7822123

回復 9# 准提部林

感謝準大糾正XD

其實我已發現問題了，只是懶的改~

想說讀資料與寫資料都用同一個陣列解決就好

但是會把前一次的判斷值也寫入Arr (會保留前一次判斷過程)

既然準大糾正了，那我還是拆成2個陣列好了~

另外，祝 準大 新年快樂 ^.^

Sub 判斷品質異常()
Const N = 8   '設定連續次數
Dim Rn&, R%, S%, T%, CL!, Arr, Brr
Dim 連續大 As Boolean, 連續小 As Boolean
Rn = Cells(Rows.Count, 1).End(xlUp).Row - 2
If Rn < 1 Then Exit Sub
CL = [C1]
Arr = [A3].Resize(Rn)
[C3].Resize(Rn, 3).ClearContents
ReDim Brr(1 To Rn, 1 To 3)
For R = 1 To Rn
  Brr(R, 1) = IIf(Arr(R, 1) > CL, 1, -1)
  S = S + Brr(R, 1)
  If S = N Then 連續大 = True: S = S - 1: Brr(R, 2) = 1
  If S = -N Then 連續小 = True: S = S + 1: Brr(R, 3) = 1
  If Brr(R, 1) <> T Then T = Brr(R, 1): S = T
Next R
[C3].Resize(Rn, 3) = Brr
If 連續大 Then MsgBox "連續" & N & "點在中心線同側(大於)"
If 連續小 Then MsgBox "連續" & N & "點在中心線同側(小於)"
End Sub