Andy2483

回復 10# jomeow


   
[calculation!B22:F30].ClearContents
[calculation!B22].Resize(M, c - 1) = Crr
======================================


明確指向資料表與結果表 版本

Option Explicit
Sub TEST_1()
Dim Brr, Crr, v&, Q%, i&, j%, R&, c%, M&, A%, K&, Ss As Worksheet, Sa As Worksheet
Set Ss = Sheets("data input"): Set Sa = Sheets("calculation")
K = 2000: Brr = Range(Ss.[A1], Ss.UsedRange.Offset(1, 0))
ReDim Crr(1 To UBound(Brr), 1 To UBound(Brr, 2))
For j = 2 To UBound(Brr, 2)
   c = c + 1: R = 0: Q = 0
   If Brr(2, j) Like "BM *" = False Then Exit For
   If Brr(3, j) = "" Then GoTo j01
   For i = 3 To UBound(Brr)
      v = v + Val(Brr(i, j)): A = A + 1
      If Trim(Brr(i + 1, j)) = "" Then Q = 1
      If (v = K And A > 1) + (v > K) + (Q = 1 And v > 0) < 0 Then
         R = R + 1: Crr(R, c) = v: v = 0: A = 0
      End If
      If Q = 1 Then Exit For
   Next
   If M < R Then M = R
j01: Next
If M = 0 Then Exit Sub
Sa.[B22:F30].ClearContents
Sa.[B22].Resize(M, c - 1) = Crr
Erase Brr, Crr
End Sub

jomeow

回復 11# Andy2483


謝謝大大的出手幫忙!

請問如有空.. 可不可以指教一下我vba內容的寫法可以嗎?

因為.. 我問了很多個群,, 只有你的答案才正確...

感恩你的幫助

hcm19522

回復 5# jomeow


    數組公式 :複製公式 不含 "=" ,貼上後加 "="   ;最前 "{" 代表 shift+ctrl+enter 三鍵一起按所產生 ,非程式裡面

Andy2483

回復 12# jomeow


    下午撥空複習再註解給參考

jomeow

回復 13# hcm19522

謝謝大大的解釋... 現在明白多了..

jomeow

回復 14# Andy2483


    謝謝你~

jomeow

回復 11# Andy2483


    非常有用... 感謝~

不過我剛才就用了你修改的兩行, 也成功了..

jomeow

回復 13# hcm19522


你教我的公式.. 我成功了...

非常感謝你的幫助...

m(_ _)m

你們都很厲害.. 可不可以讓我認識你嗎

Andy2483

回復 16# jomeow


    謝謝上論壇一起學習
Option Explicit
Sub TEST_1()
Dim Brr, Crr, v&, i&, R&, K&, M&, j%, Q%, c%, A%, Ss As Worksheet, Sa As Worksheet
'↑宣告變數:(Brr, Crr)是通用型變數,(v,i,R,K,M)是長整數,(j,Q,c,A)是短整數
'(Ss,Sa)是工作表變數
Set Ss = Sheets("data input"): Set Sa = Sheets("calculation")
'↑令Ss這工作表變數裝盛 工作表 "data input"
'↑令Sa這工作表變數裝盛 工作表 "calculation"
K = 2000: Brr = Range(Ss.[A1], Ss.UsedRange.Offset(1, 0))
'↑令K這長整數變數是常數2000
'↑令Brr這通用型變數是二維陣列,以Ss變數的[A1]到已使用儲存格下偏移一列,
'這範圍儲存格值帶入Brr陣列中
ReDim Crr(1 To UBound(Brr), 1 To UBound(Brr, 2))
'↑宣告這Crr通用型變數是二維空陣列:
'陣列上下範圍從索引號1到Brr陣列縱向最大索引列號
'陣列左右範圍從索引號1到Brr陣列橫向最大索引欄號
For j = 2 To UBound(Brr, 2)
'↑設順迴圈j:從2到 Brr陣列橫向最大索引欄號
   c = c + 1: R = 0: Q = 0
   '↑令c這短整數變數累加1
   '↑令R這長整數歸零,令Q這長整數也歸零
   If Brr(2, j) Like "BM *" = False Then Exit For
   '↑如果第2列j迴圈欄Brr陣列值不是以 BM 字串開頭!就結束j的迴圈
   If Brr(3, j) = "" Then GoTo j01
   '↑如果第3列j迴圈欄Brr陣列值是空字元!就跳到標示 j01位置繼續執行
   For i = 3 To UBound(Brr)
   '↑設順迴圈i:從3到 Brr陣列綜向最大索引列號
      v = v + Val(Brr(i, j)): A = A + 1
      '↑令v這長整數變數累加(i迴圈列/j迴圈欄Brr陣列值)轉化的數值
      If Trim(Brr(i + 1, j)) = "" Then Q = 1
      '↑如果下一個迴圈陣列值是 空字元!就令Q變數是1
      If (v = K And A > 1) + (v > K) + (Q = 1 And v > 0) < 0 Then
      '↑如果(v變數是剛好2000,而且是累加才剛好是2000的),或
      'v變數大於 2000,或v大於0 且已經是該欄最後一個數值,
      '如果以上三種條件的其中一種條件成立!
         R = R + 1: Crr(R, c) = v: v = 0: A = 0
         '↑令R變數累加1
         '↑令R變數列c變數欄Crr陣列值是v變數
         '↑令v變數歸零,A變數也歸零
      End If
      If Q = 1 Then Exit For
      '↑如果Q變數是1!就結束i迴圈
   Next
   If M < R Then M = R
   '↑如果M變數小於R變數!就令M變數 等於R變數
j01: Next
If M = 0 Then Exit Sub
'↑如果M變數是0!就結束程式執行
Sa.[B22:F30].ClearContents
'↑令Sa變數的[B22:F30]儲存格清除內容
Sa.[B22].Resize(M, c - 1) = Crr
'↑令Sa變數的[B22]向下擴展M變數列,向右擴展(c-1)欄,
'這範圍儲存格值是Crr陣列值
Erase Brr, Crr
'↑令釋放變數
End Sub

jomeow

回復 19# Andy2483


好詳細... 我要慢慢學習一下...

@o@