- 帖子
- 2839
- 主題
- 10
- 精華
- 0
- 積分
- 2895
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-12-20
|
Sub 載入()
Dim S1 As Worksheet, S2 As Worksheet, Rng1 As Range, Rng2 As Range
Dim Arr, R&, C&, Ck%, N&, xR As Range
Set S1 = Sheets("廠缺表"): Set S2 = Sheets("出貨")
Set Rng1 = S1.[B3:G3]: Set Rng2 = S1.[B4:H4]: Set xR = S1.[B3]
Application.ScreenUpdating = False
Call 清除
Arr = Range(S2.[a1], S2.UsedRange)
For C = 45 To UBound(Arr, 2)
Ck = 0
For R = 4 To UBound(Arr)
If Val(Arr(R, C)) <= 0 Then GoTo 101
If Ck = 0 Then
Rng1.Copy xR
xR.Resize(1, 6).VerticalAlignment = xlCenter '跨欄置中
xR = Arr(3, C) '廠缺名稱
Set xR = xR(2): Ck = 1
End If
'----------------------------
Rng2.Copy xR
xR.Resize(1, 4) = Array(Arr(R, 8), "", Arr(R, 7), Arr(R, C))
xR(1, 7) = Arr(R, 5)
Set xR = xR(2): N = N + 1
101: Next R
Next C
If N = 0 Then Exit Sub
Rng2.Copy xR(2)
xR(2).Resize(1, 7).ClearContents
xR(2).Resize(1, 6).Interior.ColorIndex = 37
xR(2, 4).Resize(1, 3) = "=SUM(R[-" & xR.Row - 3 & "]C:R[-1]C)"
End Sub
Sub 清除()
With Sheets("廠缺表")
.UsedRange.Offset(4, 0).EntireRow.Delete
.[B3] = ""
.[B4:G4].ClearContents
.[F4] = "=IF(MIN(D4:E4)=0,"""",INT(E4/D4))"
.[G4] = "=IF(MIN(D4:E4)=0,"""",MOD(E4,D4))"
.[H3:H4].ClearContents
End With
End Sub
 Xl0000142.rar (26.85 KB)
若需跨檔, 自行去修改~~
=========================================== |
|
發表於 2019-11-23 11:50
| 
發表於 2019-11-25 20:16
| 
