返回列表 上一主題 發帖

[發問] 自動套表

做個跨檔執行, 自行修改套用:
廠缺.rar (40.53 KB)
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

Sub 載入()
Dim S1 As Worksheet, S2 As Worksheet, Rng1 As Range, Rng2 As Range
Dim Arr, R&, C&, Ck%, N&, xR As Range
Set S1 = Sheets("廠缺表"):   Set S2 = Sheets("出貨")
Set Rng1 = S1.[B3:G3]:   Set Rng2 = S1.[B4:H4]:   Set xR = S1.[B3]
Application.ScreenUpdating = False
Call 清除
Arr = Range(S2.[a1], S2.UsedRange)
For C = 45 To UBound(Arr, 2)
    Ck = 0
    For R = 4 To UBound(Arr)
        If Val(Arr(R, C)) <= 0 Then GoTo 101
        If Ck = 0 Then
           Rng1.Copy xR
           xR.Resize(1, 6).VerticalAlignment = xlCenter '跨欄置中
           xR = Arr(3, C) '廠缺名稱
           Set xR = xR(2): Ck = 1
        End If
        '----------------------------
        Rng2.Copy xR
        xR.Resize(1, 4) = Array(Arr(R, 8), "", Arr(R, 7), Arr(R, C))
        xR(1, 7) = Arr(R, 5)
        Set xR = xR(2): N = N + 1
101: Next R
Next C
If N = 0 Then Exit Sub
Rng2.Copy xR(2)
xR(2).Resize(1, 7).ClearContents
xR(2).Resize(1, 6).Interior.ColorIndex = 37
xR(2, 4).Resize(1, 3) = "=SUM(R[-" & xR.Row - 3 & "]C:R[-1]C)"
End Sub

Sub 清除()
With Sheets("廠缺表")
    .UsedRange.Offset(4, 0).EntireRow.Delete
    .[B3] = ""
    .[B4:G4].ClearContents
    .[F4] = "=IF(MIN(D4:E4)=0,"""",INT(E4/D4))"
    .[G4] = "=IF(MIN(D4:E4)=0,"""",MOD(E4,D4))"
    .[H3:H4].ClearContents
End With
End Sub

Xl0000142.rar (26.85 KB)

若需跨檔, 自行去修改~~

===========================================
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

本帖最後由 luhpro 於 2019-11-20 22:31 編輯
回復  luhpro

大大,
有缺貨的部份,依序從"飛比"AS:BH帶資料,
測試檔中的缺貨其實只有一項(72瓶), ...
PJChen 發表於 2019-11-20 21:03


嗯? 還是跟之前一樣會發生錯誤嗎?
8# 主要是解決 ""(空字串) 與 "箱+" 造成計算錯誤的問題,
不過依你所述那其實是你沒要抓取的部分.
所以你變成只要把 7# 的程式修改這一行應該就是你要的結果了 :
    iCol = 45 '廠缺來源起始欄
    While .Cells(3, iCol) <> "劃單合計"
      sStr = .Cells(3, iCol) ' 據點名

不過這個仍然要改 :
sFlName = "最新庫存.xlsx"
  Set wsSou = Workbooks(sFlName).Sheets("飛比")
  Set diPro = CreateObject("Scripting.Dictionary") ' 商品缺數
紅色這一行要移到這裡 :
End If
    Set wsSou = Workbooks(sFlName).Sheets("飛比")
   With wsSou ' 讀取飛比資料

另外, 這行也要修改 :
  With wsTar ' 產生廠缺表
    .Range(.[A3], .Cells(Rows.Count, 8)).Delete Shift:=xlShiftUp
    lRow = 3

另外也想請問,日後若出貨據點增加時,"飛比"AS:BH欄數也會增加,請問當據點增加時要如何修改?

要加上據點,
只要在 "劃單合計" (即 BI 欄)左方插入整欄並賦與資料即可.

TOP

回復 8# luhpro

大大,
測試後."似乎"看不出有改變吔...
有缺貨的部份,依序從"飛比"AS:BH帶資料,測試檔中的缺貨其實只有一項(72瓶)
可是製表完成後會把訂單的數量帶到廠缺!!
另外也想請問,日後若出貨據點增加時,"飛比"AS:BH欄數也會增加,請問當據點增加時要如何修改?

TOP

本帖最後由 luhpro 於 2019-11-20 00:01 編輯
回復  luhpro

SOS
大大,
我依實際需求,小小的改了程式,測試時也都沒問題,但...
程式在正式使用時,發 ...
PJChen 發表於 2019-11-19 22:01

首先修正一個錯誤, 紅色這一行要移到這裡 :
  End If
    Set wsSou = Workbooks(sFlName).Sheets("飛比")
  With wsSou ' 讀取飛比資料
我們不能在 "最新庫存.xlsx" 這個檔案還沒打開前就去參照它.

其次回答你的問題,
那行有問題是因為 vD2(1) 是 空字串 (即 "" ),
系統不接受將它用來參與計算式.
再考慮到你的欠瓶數會出現日期,
所以我從源頭直接濾掉不符合數字格式的資料 :
  Dim rTar As Range
...
      sStr = .Cells(3, iCol) ' 據點名
      lRow = 4 '商品起始列
      While .Cells(lRow, 8) <> "" ' 商品名稱
        Set rTar = .Cells(lRow, iCol)
        If rTar > 0 And rTar <> "" And InStr(1, rTar, "/") = 0 Then
          If diPro.Exists(sStr) Then
            diPro(sStr) = diPro(sStr) & "," & lRow & "-" & rTar
...
        vD2 = Split(vD1(iI), "-")
        sStr = vD2(1)
...
        .Cells(lRow, 5) = sStr ' 欠瓶數
        '.Cells(lRow, 6) = Int(vD2(1) / .Cells(lRow, 4)) ' 箱 <= 刪除這行
        If InStr(1, sStr, "箱") > 0 Then ' 處理有 "箱+" 的字串
          .Cells(lRow, 6) = Left(sStr, InStr(1, sStr, "箱") - 1) ' 箱
          .Cells(lRow, 7) = Val(Mid(sStr, InStr(1, sStr, "箱") + 1)) ' 瓶
        Else ' 正常的瓶數
          .Cells(lRow, 6) = Int(sStr / .Cells(lRow, 4)) ' 箱
          .Cells(lRow, 7) = sStr Mod .Cells(lRow, 4) ' 瓶
        End If

最後, 因為有 "箱+" 的字串太長不能全部顯示出來,
故調整 E 欄欄寬 :
    .Columns("E").AutoFit
  End With
  MsgBox "缺料明細已產生完畢..."
Macro-2.zip (21.63 KB)

TOP

回復 5# luhpro

SOS
大大,
我依實際需求,小小的改了程式,測試時也都沒問題,但...
程式在正式使用時,發生了問題
停在這裡 ".Cells(lRow, 6) = Int(vD2(1) / .Cells(lRow, 4)) ' 箱"
而且跑出一些測試時未曾出現的資料,
我把它留在執行結果中,
請幫忙看下....感謝
3rd_程式與執行檔 分開.rar (136.08 KB)

TOP

回復 5# luhpro

感謝 大大,
執行沒有問題了

TOP

本帖最後由 luhpro 於 2019-11-17 01:17 編輯
回復  luhpro

請問大大,
一般我在用VBA時,用Alt + F11就可以看到Module的程式碼,為什麼您寫的程式看不到Module ?

PJChen 發表於 2019-11-16 23:12

那只是我們的切換方式不同,
你只要點一下如下圖的 "檢視程式碼" 按鈕就可以看到了.
檢視程式碼按鈕.jpg
2019-11-17 00:51


另外因為表格一開始的狀態都是空白的,填入資料時要從第3列開始,但在測試時都會從第6列開始填,可否幫忙改為起始由第3列開始寫入資料?

因為你的範例擋看到的是從第6列開始的.(隱藏了第3-5列)
需要修改底下這行數字 :
    With wsTar ' 產生廠缺表
    .Range(.[A6], .Cells(Rows.Count, 8)).Delete Shift:=xlShiftUp

    lRow = 3
    For Each vA In diPro
還有底下這行 :
    lRow = lRow - 1
    With .Range(.[B3, .Cells(lRow, 7))
       .Borders(xlEdgeLeft).LineStyle = xlContinuous

另外我的程式要放在另一檔案Macro.xlsm中執行,並指定檔名"最新庫存.xlsx"請問程式要怎麼修正?

  Dim sStr$, sPath$, sFlName$
...
  Set wsSou = ThisWorkbook.Sheets("出貨")
  Set wsTar = Sheets("廠缺表")  <=刪掉這行
  Set diPro = CreateObject("Scripting.Dictionary") ' 商品缺數  
   sPath = ThisWorkbook.Path ' 如果要指定目錄, 只要改成該目錄即可, 如 sPath = "D:"
  sFlName = "最新庫存.xlsx"
  bMatch = False ' 檢查 '最新庫存.xlsx' 檔案是否已開啟
  For iI = 1 To Workbooks.Count
    If Workbooks(iI).Name = sFlName Then
      bMatch = True
      Exit For
    End If
  Next iI
  If bMatch Then
    Set wsTar = Workbooks(sFlName).Sheets("廠缺表")
    wsTar.Activate
  Else
    Set wsTar = Workbooks.Open(Filename:=sPath & "\" & sFlName).Sheets("廠缺表")
  End If

最後, 原先的檔案中,
字形大小與箱入數顏色忘了改,
就一併處理了 :
     With .Range(.[B3], .Cells(lRow, 7))
      .Font.Size = 18
   ...
    End With
    For Each vA In diTit
...
    Next

    With .Range(.[D3], .Cells(lRow, 3))
      .Font.ColorIndex = 23
    End With


修改後完整程式如下 :
Private Sub CbCreat_Click() ' 產生明細
  Dim iI%, iCol%
  Dim lRow&
  Dim sStr$, sPath$, sFlName$
  Dim bMatch As Boolean
  Dim diPro, diTit, vA, vD1, vD2
  Dim wsSou As Worksheet, wsTar As Worksheet
  
  Set wsSou = ThisWorkbook.Sheets("出貨")
  Set diPro = CreateObject("Scripting.Dictionary") ' 商品缺數
  Set diTit = CreateObject("Scripting.Dictionary") ' 據點列數
  
  sPath = ThisWorkbook.Path ' 如果要指定目錄, 只要改成該目錄即可, 如 sPath = "D:"
  sFlName = "最新庫存.xlsx"
  bMatch = False ' 檢查 '最新庫存.xlsx' 檔案是否已開啟
  For iI = 1 To Workbooks.Count
    If Workbooks(iI).Name = sFlName Then
      bMatch = True
      Exit For
    End If
  Next iI
  If bMatch Then
    Set wsTar = Workbooks(sFlName).Sheets("廠缺表")
    wsTar.Activate
  Else
    Set wsTar = Workbooks.Open(Filename:=sPath & "\" & sFlName).Sheets("廠缺表")
  End If
  
  With wsSou ' 讀取出貨資料
    iCol = 45 '廠缺起始行
    While .Cells(3, iCol) <> ""
      sStr = .Cells(3, iCol) ' 據點名
      lRow = 4 '商品起始列
      While .Cells(lRow, 8) <> "" ' 商品名稱
        If .Cells(lRow, iCol) > 0 Then
          If diPro.Exists(sStr) Then
            diPro(sStr) = diPro(sStr) & "," & lRow & "-" & .Cells(lRow, iCol)
          Else
            diPro(sStr) = lRow & "-" & .Cells(lRow, iCol)
          End If
        End If
        lRow = lRow + 1
      Wend
      iCol = iCol + 1
    Wend
  End With

  With wsTar ' 產生廠缺表
    .Range(.[A6], .Cells(Rows.Count, 8)).Delete Shift:=xlShiftUp
    lRow = 3
    For Each vA In diPro
      With .Cells(lRow, 2).Resize(, 6) ' 據點名
        With .Cells(1)
          .Value = vA
          diTit(vA) = lRow
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          With .Font
            .Size = 22
            .Bold = False
          End With
        End With
        
        With .Interior
            .Pattern = xlPatternLinearGradient
            .Gradient.Degree = 90
            .Gradient.ColorStops.Clear
          With .Gradient.ColorStops.Add(0)
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
          End With
          With .Gradient.ColorStops.Add(1)
            .Color = 118671
            .TintAndShade = 0
          End With
        End With
      End With
      lRow = lRow + 1
      
      sStr = diPro(vA)
      vD1 = Split(sStr, ",")
      For iI = 0 To UBound(vD1)
        vD2 = Split(vD1(iI), "-")
        .Cells(lRow, 1) = wsSou.Cells(vD2(0), 6) ' 料號
        .Cells(lRow, 2) = wsSou.Cells(vD2(0), 8) ' 商品名稱
        .Cells(lRow, 4) = wsSou.Cells(vD2(0), 7) ' 箱入數
        .Cells(lRow, 5) = vD2(1) ' 欠瓶數
        .Cells(lRow, 6) = Int(vD2(1) / .Cells(lRow, 4)) ' 箱
        .Cells(lRow, 7) = vD2(1) Mod .Cells(lRow, 4) ' 瓶
        .Cells(lRow, 8) = wsSou.Cells(vD2(0), 5) ' 膠帶
        lRow = lRow + 1
      Next
    Next
   
    lRow = lRow - 1
    With .Range(.[B3], .Cells(lRow, 7))
      .Font.Size = 18
      .Borders(xlEdgeLeft).LineStyle = xlContinuous
      .Borders(xlEdgeTop).LineStyle = xlContinuous
      .Borders(xlEdgeBottom).LineStyle = xlContinuous
      .Borders(xlEdgeRight).LineStyle = xlContinuous
      .Borders(xlInsideVertical).LineStyle = xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    For Each vA In diTit
      With .Cells(diTit(vA), 2).Resize(, 6)
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
      End With
    Next
    With .Range(.[D3], .Cells(lRow, 3))
      .Font.ColorIndex = 23
    End With
  End With
  MsgBox "缺料明細已產生完畢..."
End Sub

自動套表-Ans2.zip (56.31 KB)

TOP

本帖最後由 PJChen 於 2019-11-16 23:17 編輯

回復 2# luhpro

請問大大,
一般我在用VBA時,用Alt + F11就可以看到Module的程式碼,為什麼您寫的程式看不到Module ?
另外因為表格一開始的狀態都是空白的,填入資料時要從第3列開始,但在測試時都會從第6列開始填,可否幫忙改為起始由第3列開始寫入資料?
另外我的程式要放在另一檔案Macro.xlsm中執行,並指定檔名"最新庫存.xlsx"請問程式要怎麼修正?
謝謝您

TOP

回復 2# luhpro
真是太感謝了...

TOP

        靜思自在 : 人的眼睛長在前面,只看到別人的缺點,絲毫看不到自己的缺點。
返回列表 上一主題