返回列表 上一主題 發帖

[發問] 對應日期貼盤點資料

本帖最後由 准提部林 於 2021-12-15 21:14 編輯

沒詳細看要抓什麼數據, 隨便寫一個參考, 自行了解程式碼再根據需求改改:
Sub 盤點_期初庫存()
Dim Arr, DD, PH$, FN1$, FN2$, FT$
Dim xB1 As Workbook, xS1 As Worksheet, xB2 As Workbook, xS2 As Worksheet
Dim xF1 As Range, xF2 As Range, TT$, DY
Application.ScreenUpdating = False
PH = ThisWorkbook.Path & "\"
FN2 = Range("B8")
If FN2 = "" Then MsgBox "指定檔名稱未輸入!  ": Exit Sub
FN2 = Dir(PH & FN2 & "*.xls*")
If FN2 = "" Then MsgBox "指定檔不存在!  ": Exit Sub
'----------------------------------
FN1 = "多客戶盤點表.xls"
On Error Resume Next: Set xB1 = Workbooks(FN1): On Error GoTo 0
If xB1 Is Nothing Then Set xB1 = Workbooks.Open(PH & FN1)
'-----------------------------------
On Error Resume Next: Set xB2 = Workbooks(FN2): On Error GoTo 0
If xB2 Is Nothing Then Set xB2 = Workbooks.Open(PH & FN2)
FT = Split(FN2, "倉庫")(0) '截取[客戶]名稱
'-----------------------------------
ThisWorkbook.Activate
Set xS1 = xB1.Sheets("盤點")
DD = xS1.[e4]
Arr = Range(xS1.[di1], xS1.[a6536].End(3))
For i = 6 To UBound(Arr) Step 2
    TT = Arr(i, 5) '品名
    DY = Day(DD + Arr(i, UBound(Arr, 2)) - 1) '日期--day..以 di 欄取當天或前一天
    If Arr(i, 1) <> FT Or TT = "" Then GoTo i01
    On Error Resume Next: Set xS2 = xB2.Sheets(DY & ""): On Error GoTo 0
    If xS2 Is Nothing Then GoTo i01
    Set xF1 = xS2.Cells.Find("期末", Lookat:=xlWhole) '找[期末庫存]位置
    Set xF2 = xS2.[b:b].Find(TT, Lookat:=xlWhole) '找B欄[品名]位置
    If xF1 Is Nothing Or xF2 Is Nothing Then GoTo i01
    xS1.Cells(i, 13) = xS2.Cells(xF2.Row, xF1.Column)
i01: Next i
MsgBox "期初庫存載入完成, 多客戶盤點表尚未儲存, 若確定無誤再手動存檔!  "
End Sub

TOP

回復 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

TOP

        靜思自在 : 站在半路,比走到目標更辛苦。
返回列表 上一主題