- 帖子
- 1480
- 主題
- 40
- 精華
- 0
- 積分
- 1504
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-10-27
|
5#
發表於 2023-11-14 08:46
| 只看該作者
本帖最後由 Andy2483 於 2023-11-14 10:14 編輯
回復 3# 准提部林
謝謝論壇,謝謝前輩指導
後學學習前輩的方案,心得註解如下,請前輩再指導
Option Explicit
Sub TEST_A1()
Dim Arr, Brr, i&, N&, R&, j%, k%, Cn%, V%, V1%, V2%
'↑宣告變數:(Arr,Brr)是通用型變數,(N,R)是長整數,(j,k,Cn,V,V1,V2)是短整數
Sheets("Sheet2").[a:j].ClearContents
'↑令名為"Sheet2" 工作表的A:J欄儲存格清除內容
Arr = Range(Sheets("Sheet1").[j1], Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp)(2))
'↑令Arr這通用型變數是 二維陣列,以表1的[J1]到A欄最後有內容儲存格的下一格,以此範圍儲存格值帶入Arr陣列中
ReDim Brr(1 To 30000, 1 To 10)
'↑宣告Brr這通用型變數是二維空陣列,縱向範圍從索引號1到30000,橫向範圍從索引號1 到10
For i = 2 To UBound(Arr) - 1
'↑設順迴圈!i從2 到Arr陣列縱向最大索引列號-1
V = IIf(Arr(i, 10) = "HT", 1000, 3000) '除數
'↑令V這短整數是 IIF()回傳值:如果i迴圈列第10欄Arr陣列值自字串 "HT",True回傳數值1000,False回傳數值 3000
V1 = Val(Arr(i, 7)) '數量
'↑令V1這短整數是 i迴圈列第7欄Arr陣列值轉成數值
Cn = Int(V1 / V) + 1 '分拆行數
'↑令Cn這短整數是 V1變數除以V變數後去除小數的整數值+1
V2 = V1 Mod V '餘數
'↑令V2這短整數是 V1變數除以V變數的餘數
If V2 < 101 And Cn > 1 Then Cn = Cn - 1: V2 = V + V2
'↑如果V2變數<101 且Cn變數>1 ? True就令Cn變數-1:令V2變數是自身累加V變數
For j = 1 To Cn
'↑設順迴圈!j從1 到Cn變數
N = N + 1
'↑令N變數累加1
For k = 1 To 10: Brr(N, k) = Arr(i, k): Next
'↑設順迴圈!令k從1到10:將i列k變數欄Arr陣列值帶入 N變數列k變數欄Brr陣列中
Brr(N, 7) = IIf(j = Cn, V2, V)
'↑令N變數列第7欄陣列值是IIF()回傳值: 如果j變數同Cn變數!回傳V2變數,否則回傳V變數
Next j
If Arr(i, 8) <> Arr(i + 1, 8) And N Mod 2 = 1 Then N = N + 1
'↑如果i迴圈列第8欄Arr陣列值與下一列第8欄Arr陣列值不同,且N變數除以2的餘數是1?
'True就令N變數累加1
Next i
Sheets("Sheet2").[a1:j1] = Sheets("Sheet1").[a1:j1].Value
'↑令表2的標題列同 表1的標題列
Sheets("Sheet2").[a2].Resize(N, 10) = Brr
'↑令表2的[A2]擴展向下N變數列,擴展向右10欄的範圍儲存格值以Brr陣列值帶入
End Sub
===========================================================
Option Explicit
Sub TEST()
Dim Brr, Crr, V%, V1%, Q%, i&, j%, R&
Dim S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("Sheet1"): Set S2 = Sheets("Sheet2")
Brr = Range(S1.[J1], S1.Cells(Rows.Count, "A").End(3))
ReDim Crr(1 To 10000, 1 To 10)
For i = 2 To UBound(Brr)
Q = Val(Brr(i, 7))
V = IIf(Brr(i, 10) = "HT", 1000, 3000)
qq:
If Q <= 0 Then GoTo i01 Else R = R + 1: V1 = Q - V
For j = 1 To 10: Crr(R, j) = Brr(i, j): Next
Crr(R, 7) = V * -(V1 >= 0) + Q * -(V1 < 0)
Q = V1: GoTo qq
i01: Next
S2.[A:J].ClearContents
S2.[A1:J1] = S1.[A1:J1].Value
S2.[a2].Resize(R, 10) = Crr
Set S1 = Nothing: Set S2 = Nothing: Erase Brr, Crr
End Sub |
|
發表於 2021-10-24 16:54
| 
