- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-12-5
|
29#
發表於 2023-10-26 07:53
| 只看該作者
本帖最後由 Andy2483 於 2023-10-26 08:00 編輯
回復 27# jomeow
輸入窗輸入0的執行結果:
輸入窗輸入1的執行結果:
Option Explicit
Sub TEST_1()
Dim Brr, Crr, v&, i&, R&, K&, M&, j%, Q%, c%, A%, Ss As Worksheet, Sa As Worksheet, iBox
'↑宣告變數:(Brr,Crr,iBox)是通用型變數,(v,i,R,K,M)是長整數,(j,Q,c,A)是短整數
'(Ss,Sa)是工作表變數
iBox = InputBox("0是不足2000繼續累加!" & vbLf & "1是累加剛好是2000的不再累加", "請輸入0 或1", 0)
'↑令iBox這通用型變數是 輸入窗回傳值
If StrPtr(iBox) = 0 Then Exit Sub Else iBox = IIf(Val(iBox) > 0, 1, 0)
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) * iBox + (v > K) + (Q = 1 And v > 0) < 0 Then
'↑如果(v變數是剛好2000,而且是累加才剛好是2000且輸入是1),或
'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陣列值
Application.Goto Sa.[B22].Resize(M, c - 1)
'↑令視窗跳到結果位置
Erase Brr, Crr
'↑令釋放變數
End Sub |
|
