軒云熊

回復 50# 准提部林

謝謝 準大 小弟研究一下 感謝

PJChen

回復 50# 准提部林

准大好,

1) FT = Split(FN2, "庫存表")(0)
客戶檔名大多以XXX庫存表 命名

但FT = Split(FN2, "庫存表")(0) '截取[客戶]名稱
這裡是用最大多數的"庫存表"來分離字串
但因為同一客戶有不同廠別,
例如：佳佳中壢廠庫存表
在[B8]會輸入"佳佳中壢廠庫存表"
這樣又會抓不到檔案
請問如何修改?
FT = Split(FN2, "庫存表")(0)

2)
將程式改為抓取盤點資料時,
還需要加入一段比對日期的程式
比對規則
客戶庫存表的第7列,對應"多客戶盤點表"的第6列
請問以下程式要怎麼修改?
    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, 60) = xS2.Cells(xF2.Row, xF1.Column) '多客戶盤點欄=60

准提部林

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

PJChen

回復 53# 准提部林
准大好,

測試多日,期初&盤點資料,都正確...
感謝！