返回列表 上一主題 發帖

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

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

本帖最後由 PJChen 於 2021-7-4 13:36 編輯

大大們好,
    With Sh
    Sh.Activate
        For j = 6 To xrow Step 2
            .Range("X" & j + 1 + 1).Resize(1, 16).Copy
            xW.Sheets("盤點").Range("BO" & 1 + j).Resize(1, 16).PasteSpecial xlPasteValues
        Next
    End With

盤點工作表從A欄的各客戶檔案把相應的盤點資料,copy過來
E4是指定日期
A欄是客戶名
當DI欄= D+0則從客戶檔案的數字工作表找E4-1的工作表
ex:E4=7/3,則找"2"工作表
將x:am的盤點資料,有庫存的數字,對應日期相符,貼到盤點工作表的BH:CF的欄位中

來源各客戶的檔案格式不會完全相同,但都是類似的,只以一定作範本,
盤點工作表中有很多的公式,所以貼上的資料不能干擾其他儲存格,
請問(紅字)對應日期貼上盤點數值的這段程式該怎麼寫?   貼盤點資料.rar (328.03 KB)
  1. Sub copy_蜜蜂盤點()
  2. Dim PH$, FN$, W As Workbook, xW As Workbook, xD As Worksheet, xS As Worksheet, Sh As Worksheet, i As String, rng As Range
  3. Set xD = ThisWorkbook.Sheets("VBA")  '程式來源
  4. k = xD.[V1] - 1 '取前一日
  5. i = Format(k, "D")
  6. y = Format(k, "yyyy")
  7. m = Format(k, "m")
  8. '---------------------
  9. Set xW = Workbooks("多客戶盤點表")
  10. PH = xD.[BB1]
  11. '---------------------
  12. FN = Dir(PH & "*蜜蜂*" & y & "*" & m & ".xlsx")
  13. Do While FN <> ""
  14. On Error Resume Next: Set W = Workbooks(FN): On Error GoTo 0
  15. If W Is Nothing Then Set W = Workbooks.Open(PH & FN)
  16. Set Sh = W.Sheets(i)
  17. With Sh
  18.     xrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row + 5
  19. End With
  20.      xW.Sheets("盤點").Range("M6:M" & xrow) = Sh.Range("T7:T" & xrow).Value '來源 前日結餘   
  21. With Sh
  22.     Sh.Activate
  23.         For j = 6 To xrow Step 2
  24.             .Range("X" & j + 1 + 1).Resize(1, 16).Copy
  25.             xW.Sheets("盤點").Range("BO" & 1 + j).Resize(1, 16).PasteSpecial xlPasteValues
  26.         Next
  27.     End With
  28.    
  29. FN = Dir
  30. Loop
  31. End Sub
複製代碼

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

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

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

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

TOP

回復 50# 准提部林

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

TOP

本帖最後由 准提部林 於 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

本帖最後由 軒云熊 於 2021-12-15 08:55 編輯

回復 48# PJChen

發現盤點無數據時,無法貼上期初值    <----把判斷註解了

已經把程式 複製並分開了 有空再幫我試試看 有問題再跟我說 感謝


Macro_1_1215.rar (44.32 KB)

TOP

回復 47# 軒云熊
熊大好,
請問現將期初&盤點合為一個程式,原先是希望分成二個程式的!
因為有時會分開使用....

目前只能先以測試檔測試
發現盤點無數據時,無法貼上期初值

TOP

本帖最後由 軒云熊 於 2021-12-14 14:21 編輯

回復 45# PJChen

這是加入 期末和盤點 一起比對 有空再幫我試試看還有沒有問題 感謝

Macro_1_1214_.rar (40.71 KB)

TOP

本帖最後由 軒云熊 於 2021-12-14 13:29 編輯

回復 45# PJChen

有空再幫我試試看行不行 感謝  但 迴圈變多了用了7個迴圈..... 速度也會變慢看看有沒有大大可以幫忙^^"
    javascript:;

Macro_1_1214.rar (37.31 KB)

TOP

        靜思自在 : 君子如水,隨方就圓,無處不自在。
返回列表 上一主題