- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
- Sub TEST()
- Dim R%, C&, xDate$, Arr, Brr, Crr, i&, j&, N&
- Dim xB As Workbook, xS As Worksheet, SS%
- R = Cells(Rows.Count, "D").End(xlUp).Row - 9 '資料列數(含標題列)
- C = Cells(10, Columns.Count).End(xlToLeft).Column - 15 '(Order欄數)
- If R <= 0 Or C <= 0 Then Exit Sub
- xDate = [G1] '日期
- Arr = [D10].Resize(R) '產品CODE
- Brr = [P10].Resize(R, C) 'Order資料區
- Set xB = Workbooks.Add '開新檔案
- For i = C To 1 Step -1
- If Brr(1, i) = "" Then GoTo 101
- Set xS = xB.Sheets.Add: xS.Name = Brr(1, i) '新增工作表
- xS.[C:C].ColumnWidth = 11 '日期欄寬
- N = 0: SS = SS + 1 '新增工作表累計張數
- For j = 2 To R
- If Brr(j, i) <> "" Then
- N = N + 1
- xS.Cells(N, 1).Resize(1, 9) = Array("DK", "", "'" & xDate, "DN", "B99", Brr(1, i), Arr(j, 1), "", Brr(j, i))
- End If
- Next
- 101: Next i
- Application.DisplayAlerts = False
- If SS > 0 Then
- For i = xB.Sheets.Count To SS + 1 Step -1
- xB.Sheets(i).Delete '刪除新檔案預設空白工作表
- Next
- End If
- xB.SaveAs Filename:=ThisWorkbook.Path & "\明細表_" & xDate & ".xls", CreateBackup:=False '另存新檔
- End Sub
 Xl0000061.rar (16.85 KB)
|
|
發表於 2017-1-9 21:07
| 