- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
5#
發表於 2020-12-31 02:18
| 只看該作者
本帖最後由 n7822123 於 2020-12-31 02:32 編輯
回復 4# lovenice831
感覺跟我想的差不多吧!?~~ 你無法收附件?
我貼程式給你，你執行"收貨報表"即可~後面都是副程式
錄製的巨集 500多列，應該沒人看得下去.....=.=，你先試看看，有漏填再說
另外，如果你沒辦法下載我的附件，請把你的報告範本"稍微"修改一下
把列19、20、21 都改成資料列，列20別用粗體框線，
當資料多餘3列，我的程式會自動複製列20
Dim Arr
Sub 收貨報表()
Dim Brr(), R&, K%, LotNo$
Application.ScreenUpdating = False
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
If Arr(R, 5) <> LotNo Then 新表 R: LotNo = Arr(R, 5): K = 0
K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
Brr(1, K) = Arr(R, 9) '貨物名稱
Brr(3, K) = LotNo '批號
Brr(4, K) = Arr(R, 7) '板號
Brr(5, K) = Arr(R, 8) '箱號
Brr(8, K) = Arr(R, 10) '實物收貨
If R + 1 > UBound(Arr) Then 另存新檔 Brr: Exit For
If Arr(R + 1, 5) <> LotNo Then 另存新檔 Brr
Next R: Erase Arr: Erase Brr
Sheets("Receiving DATA").Activate
End Sub
Sub 新表(ByVal R)
Sheets("Receiving Report").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Lot No. " & Arr(R, 5)
[C10] = Int(Arr(R, 2)) '收貨日期
[F10] = Arr(R, 2) - [C10] '收貨時間
[C11] = Arr(R, 3) '櫃號/貨車車牌
[J8] = Arr(R, 5) 'Lot Number
[J10] = Arr(R, 11) 'PO No.
[J11] = Arr(R, 14) 'BD 負責人
End Sub
Sub 另存新檔(ByVal Brr)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
Brr = Application.Transpose(Brr)
Rn = UBound(Brr): [G13] = Rn
If Rn >= 4 Then
Rows("21:" & 21 + Rn - 4).Insert Shift:=4
Rows(20).Copy
Rows("21:" & 21 + Rn - 4).Select
ActiveSheet.Paste
End If: [A10].Select
Application.CutCopyMode = False
[A19].Resize(Rn, 11) = Brr
[H13] = WorksheetFunction.Sum([E19].Resize(Rn))
ActiveSheet.Copy
With ActiveSheet
.Parent.SaveAs MyPath & .Name & ".xls", xlNormal
.Parent.Close 1
End With
ActiveSheet.Delete
End Sub
 test Receiving Data 2020-1231.rar (49.93 KB)
|
|
發表於 2021-1-1 12:46
| 