- 帖子
- 2839
- 主題
- 10
- 精華
- 0
- 積分
- 2895
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-12-20
|
53#
發表於 2021-12-18 11:36
| 只看該作者
回復 52# PJChen
Sub 盤點_指定日數量_載入()
Dim Arr, Brr, Crr(1 To 25), xD, i&, j%, k%
Dim xB As Workbook, xS As Worksheet, xNN$, vB As Workbook, vS As Worksheet, vNN$
Dim PH$, xN$, DD, D$(1), xF As Range
Application.ScreenUpdating = False
Set xD = CreateObject("Scripting.Dictionary")
PH = ThisWorkbook.Path & "\"
vNN = Range("B8")
If vNN = "" Then MsgBox "指定檔名稱未輸入! ": Exit Sub
vNN = Dir(PH & vNN & "*.xls*")
If vNN = "" Then MsgBox "指定檔不存在! ": Exit Sub
'----------------------------------
xNN = "多客戶盤點表.xls"
On Error Resume Next: Set xB = Workbooks(xNN): On Error GoTo 0
If xB Is Nothing Then Set xB = Workbooks.Open(PH & xNN)
Set xS = xB.Sheets("盤點"): DD = CDate(xS.[e4])
D(0) = Day(DD - 1): D(1) = Day(DD)
Arr = Range(xS.[di1], xS.[a6536].End(3))
'-----------------------------------
On Error Resume Next: Set vB = Workbooks(vNN): On Error GoTo 0
If vB Is Nothing Then Set vB = Workbooks.Open(PH & vNN)
For k = 0 To 1
Set vS = vB.Sheets(D(k) & "")
Brr = vS.UsedRange
Set xF = vS.Cells.Find("盤點", Lookat:=xlWhole).MergeArea
For i = xF.Row + 2 To UBound(Brr) Step 2
If Brr(i, 2) = "" Then GoTo i01 '品名空白
For j = xF.Column To xF.Column + xF.Columns.Count - 1
xD(Brr(i, 2) & "|" & k & "|" & CLng(Brr(i, j))) = Brr(i + 1, j)
Next j
i01: Next i
Next k
vB.Close 0
'-----------------------------------
For i = 6 To UBound(Arr) Step 2
If InStr("/" & vNN, Arr(i, 1)) <> 2 Or Arr(i, 5) = "" Then GoTo i02 '客戶名稱比對
For j = 1 To UBound(Crr)
Crr(j) = xD(Arr(i, 5) & "|" & Arr(i, UBound(Arr, 2)) & "|" & CLng(Arr(i, j + 59)))
Next j
xS.Cells(i + 1, 60).Resize(1, UBound(Crr)) = Crr: Erase Crr()
i02: Next i
xB.Activate: xS.Activate
Erase Arr, Brr: Set xD = Nothing: Set xB = Nothing: Set vB = Nothing: Set xS = Nothing: Set vS = Nothing
MsgBox "盤點數量載入完成, 多客戶盤點表尚未儲存, 若確定無誤再手動存檔! "
End Sub |
|
發表於 2021-12-16 10:56
| 
