Board logo

標題: [發問] 自動套表 [打印本頁]
作者: PJChen    時間: 2019-11-5 19:02     標題: 自動套表

Dear,
我不知道這個套表問題能否用函數解決,但因為表格中的資料大多用函數套出來的,所以在這裡發問...   [attach]31387[/attach]
        出貨sheet是一個每天出貨用的表格,所以資料是變動的
        因為檔案很大,我把與補貨明細無關的資料都Delete,避免干擾
        每天的缺貨都需要這張報表去發給補貨的單位
        除了表頭1:2外,這張報表每天初始都是空白的
        我要把出貨sheet的資料套進來,請教用函數比較好做,還是VBA?
       
        出貨sheet要套過來的貨料:
1..        有缺貨的部份，依序從AS:BH帶資料
2..        我先做一個2個範例"林口" & "暖暖1"
3..        現在無法達成的部份在於
        要如何讓有缺貨的AS:BH的表頭自動帶到這裡的B欄?但無缺貨的自動跳過！
        並且讓缺貨的料號自動帶到A欄?
4..        第2筆缺貨的表頭 "暖暖1"帶入B欄,料號自動帶到A欄後
        如何讓E欄的公式以暖暖1為對象?而不用各別修改公式?
例：        =SUMPRODUCT((出貨!$F$4:$F$12=$A7)*(出貨!$AS$3:$BH$3=B$6)*(出貨!$AS$4:$BH$12))
        如何讓(出貨!$AS$3:$BH$3自動搜尋B$6),而不用各別改?
作者: luhpro    時間: 2019-11-16 16:41

Dear,
我不知道這個套表問題能否用函數解決,但因為表格中的資料大多用函數套出來的,所以在這裡發問...   
...
PJChen 發表於 2019-11-5 19:02


使用儲存格公式的方式我想不出來,
在此只能使用 Excel VBA 嘗試達成 :
只要點擊 廠缺表 的 "產生明細" 按鈕,
結果就出來了...
程式如下 :
  1. Private Sub CbCreat_Click() ' 產生明細
  2.   Dim iI%, iCol%
  3.   Dim lRow&
  4.   Dim sStr$
  5.   Dim diPro, diTit, vA, vD1, vD2
  6.   Dim wsSou As Worksheet, wsTar As Worksheet
  7.   
  8.   Set wsSou = Sheets("出貨")
  9.   Set wsTar = Sheets("廠缺表")
  10.   Set diPro = CreateObject("Scripting.Dictionary") ' 商品缺數
  11.   Set diTit = CreateObject("Scripting.Dictionary") ' 據點列數
  12.   
  13.   
  14.   With wsSou ' 讀取出貨資料
  15.     iCol = 45 '廠缺起始行
  16.     While .Cells(3, iCol) <> ""
  17.       sStr = .Cells(3, iCol) ' 據點名
  18.       lRow = 4 '商品起始列
  19.       While .Cells(lRow, 8) <> "" ' 商品名稱
  20.         If .Cells(lRow, iCol) > 0 Then
  21.           If diPro.Exists(sStr) Then
  22.             diPro(sStr) = diPro(sStr) & "," & lRow & "-" & .Cells(lRow, iCol)
  23.           Else
  24.             diPro(sStr) = lRow & "-" & .Cells(lRow, iCol)
  25.           End If
  26.         End If
  27.         lRow = lRow + 1
  28.       Wend
  29.       iCol = iCol + 1
  30.     Wend
  31.   End With
  32.   
  33. '12 粗 18
  34. '[d8].Font.ColorIndex = 23


  37.   With wsTar ' 產生廠缺表
  38.     .Range(.[A6], .Cells(Rows.Count, 8)).Delete Shift:=xlShiftUp
  39.     lRow = 6
  40.     For Each vA In diPro
  41.       With .Cells(lRow, 2).Resize(, 6) ' 據點名
  42.         With .Cells(1)
  43.           .Value = vA
  44.           diTit(vA) = lRow
  45.           .HorizontalAlignment = xlCenter
  46.           .VerticalAlignment = xlCenter
  47.           With .Font
  48.             .Size = 22
  49.             .Bold = False
  50.           End With
  51.         End With
  52.         
  53.         With .Interior
  54.             .Pattern = xlPatternLinearGradient
  55.             .Gradient.Degree = 90
  56.             .Gradient.ColorStops.Clear
  57.           With .Gradient.ColorStops.Add(0)
  58.             .ThemeColor = xlThemeColorDark1
  59.             .TintAndShade = 0
  60.           End With
  61.           With .Gradient.ColorStops.Add(1)
  62.             .Color = 118671
  63.             .TintAndShade = 0
  64.           End With
  65.         End With
  66.       End With
  67.       lRow = lRow + 1
  68.       
  69.       sStr = diPro(vA)
  70.       vD1 = Split(sStr, ",")
  71.       For iI = 0 To UBound(vD1)
  72.         vD2 = Split(vD1(iI), "-")
  73.         .Cells(lRow, 1) = wsSou.Cells(vD2(0), 6) ' 料號
  74.         .Cells(lRow, 2) = wsSou.Cells(vD2(0), 8) ' 商品名稱
  75.         .Cells(lRow, 4) = wsSou.Cells(vD2(0), 7) ' 箱入數
  76.         .Cells(lRow, 5) = vD2(1) ' 欠瓶數
  77.         .Cells(lRow, 6) = Int(vD2(1) / .Cells(lRow, 4)) ' 箱
  78.         .Cells(lRow, 7) = vD2(1) Mod .Cells(lRow, 4) ' 瓶
  79.         .Cells(lRow, 8) = wsSou.Cells(vD2(0), 5) ' 膠帶
  80.         lRow = lRow + 1
  81.       Next
  82.     Next
  83.    
  84.     lRow = lRow - 1
  85.     With .Range(.[B6], .Cells(lRow, 7))
  86.       .Borders(xlEdgeLeft).LineStyle = xlContinuous
  87.       .Borders(xlEdgeTop).LineStyle = xlContinuous
  88.       .Borders(xlEdgeBottom).LineStyle = xlContinuous
  89.       .Borders(xlEdgeRight).LineStyle = xlContinuous
  90.       .Borders(xlInsideVertical).LineStyle = xlContinuous
  91.       .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  92.     End With
  93.     For Each vA In diTit
  94.       With .Cells(diTit(vA), 2).Resize(, 6)
  95.         .Borders(xlInsideVertical).LineStyle = xlNone
  96.         .Borders(xlInsideHorizontal).LineStyle = xlNone
  97.       End With
  98.     Next
  99.   End With
  100.   MsgBox "缺料明細已產生完畢..."
  101. End Sub
複製代碼
[attach]31417[/attach]
作者: PJChen    時間: 2019-11-16 22:31

回復 2# luhpro
真是太感謝了...
作者: PJChen    時間: 2019-11-16 23:12

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

回復 2# luhpro

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

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

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

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

那只是我們的切換方式不同,
你只要點一下如下圖的 "檢視程式碼" 按鈕就可以看到了.
[attach]31420[/attach]

另外因為表格一開始的狀態都是空白的,填入資料時要從第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
[attach]31419[/attach]
作者: PJChen    時間: 2019-11-17 12:41

回復 5# luhpro

感謝 大大,
執行沒有問題了
作者: PJChen    時間: 2019-11-19 22:01

回復 5# luhpro

SOS
大大,
我依實際需求,小小的改了程式,測試時也都沒問題,但...
程式在正式使用時,發生了問題
停在這裡 ".Cells(lRow, 6) = Int(vD2(1) / .Cells(lRow, 4)) ' 箱"
而且跑出一些測試時未曾出現的資料,
我把它留在執行結果中,
請幫忙看下....感謝
[attach]31428[/attach]
作者: luhpro    時間: 2019-11-19 23:57

本帖最後由 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 "缺料明細已產生完畢..."
[attach]31429[/attach]
作者: PJChen    時間: 2019-11-20 21:03

回復 8# luhpro

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

本帖最後由 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 欄)左方插入整欄並賦與資料即可.
作者: 准提部林    時間: 2019-11-23 11:50

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

[attach]31446[/attach]

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

===========================================
作者: 准提部林    時間: 2019-11-23 12:07

做個跨檔執行, 自行修改套用:
[attach]31447[/attach]
作者: PJChen    時間: 2019-11-25 20:16

回復 12# 准提部林

感謝准大,
多天來 現在才有空可以上網查看, 這幾天因為有新工作,累斃了....
等我測試下再報告
作者: PJChen    時間: 2019-11-25 22:42

本帖最後由 PJChen 於 2019-11-25 22:43 編輯

回復 12# 准提部林

准大好,
我依現行的測試檔,把程式修改檔名後
程式測試結果留在廠缺表中(不是 自動廠缺表)
它與8樓的程式測試相同,當"飛比"sheet有訂單數據時,
訂單資料會連同廠缺,一起呈現在廠缺表中
再麻煩看下, 感謝
[attach]31453[/attach]
作者: 准提部林    時間: 2019-11-30 11:33

回復 14# PJChen

看不懂你的問題,
1)若要資料放在"自動廠缺表",
  將 Sheets("廠缺表") 改成 Sheets("自動廠缺表")
2)廠缺欄位數若是固定的:
  For C = 45 To UBound(Arr, 2)
  改成 For C = 45 To 60

或
For C = 45 To UBound(Arr, 2)
    Ck = 0
    If Arr(3, C) = "劃單合計" Then Exit For  '加入這一行, 以[劃單合計]判斷廠缺欄位的結束點
作者: PJChen    時間: 2020-2-24 20:29

回復 15# 准提部林
這陣子因為作業內容有變動,所以表格也大幅修改,請幫忙看下....
1)  For C = 45 To UBound(Arr, 2)
  改成 For C = 45 To 60
這個方法測試後OK,
在執行廠缺表後會出現自動加總(目前在第8列)
我想加個"合計",請問在程式哪個地方可以加入?

2) 另外這個方式,我還試不出來,請問我加入的地方是否不對?
For C = 45 To UBound(Arr, 2)
    Ck = 0
    If Arr(3, C) = "劃單合計" Then Exit For  '加入這一行, 以[劃單合計]判斷廠缺欄位的結束點
[attach]31749[/attach]
作者: PJChen    時間: 2020-2-24 23:51

回復 15# 准提部林
補充:
廠缺表.sheet A欄的料號,不知能否讓它一併出現?
作者: cucu    時間: 2020-2-24 23:58

回復 1# PJChen

我不會VBA，只能用其他方法做出類似的給您參考。
主要是用資料-從表格/範圍  利用出貨sheet內容以Power Query 編輯器去整理資料，
最後再用樞紐分析表去產生補貨明細。
以上，大致內容如附件
[attach]31750[/attach]
作者: PJChen    時間: 2020-2-25 15:21

回復 15# 准提部林
Dear准大,
重新整理一下...
1) 執行廠缺表後會出現自動加總,我想加個"合計",請問在程式哪個地方可以加入?
2) 廠缺表.sheet A欄加入料號,如果要大幅修改程式、不好做的話,就算了！我再自己手動加入
3) 廠缺表 F:G(箱瓶)如何讓它自動計算後,變成值,不要有公式?加總欄也是...
作者: 准提部林    時間: 2020-2-28 10:57

回復 19# PJChen

測試檔:
[attach]31752[/attach]
作者: PJChen    時間: 2020-3-1 19:35

本帖最後由 PJChen 於 2020-3-1 19:54 編輯

回復 20# 准提部林
准大,
執行後發現報表改成了訂單統計而不是缺料表,它的應抓取範圍是AP:BH

我主要是想了解您之前回覆的程式
For C = 45 To UBound(Arr, 2)
    Ck = 0
    If Arr(3, C) = "劃單合計" Then Exit For  '加入這一行, 以[劃單合計]判斷廠缺欄位的結束點
這個方式,我試不出來,想知道要怎麼修改

以下是之前程式run的結果,我只是想要加入紅字的部份 & 檔案[attach]31764[/attach]
[attach]31763[/attach]
作者: PJChen    時間: 2020-4-16 22:47

大大好,

最近有一個新的表格需求: 將廠缺資料匯總,條件為以下,請問VBA要如何寫?
1..        飛比BI欄大於0的資料,填入A3:F
2..        A3:F資料值化
3..        將第3列的格式向下複製
[attach]31917[/attach]
作者: 准提部林    時間: 2020-4-17 09:39

回復 22# PJChen

Sub 廠缺匯總_匯入()
Dim Arr, R&, 廠缺數&, 入數&, N&
Call 廠缺匯總_清除
Arr = Range([飛比!A1], [飛比!BI65536].End(xlUp))
For R = 4 To UBound(Arr)
    廠缺數 = Val(Arr(R, UBound(Arr, 2)))
    入數 = Val(Arr(R, 7))
    If 廠缺數 * 入數 = 0 Then GoTo 101
    N = N + 1
    Arr(N, 1) = Arr(R, 6)
    Arr(N, 2) = Arr(R, 5)
    Arr(N, 3) = Arr(R, 8)
    Arr(N, 4) = 入數
    Arr(N, 5) = 廠缺數 Mod 入數
    Arr(N, 6) = Int(廠缺數 / 入數)
101: Next R
If N = 0 Then Exit Sub
With [廠缺匯總!A3:F3].Resize(N)
     .Rows(1).Copy .Cells
     .Value = Arr
End With
End Sub


Sub 廠缺匯總_清除()
With Sheets("廠缺匯總")
    .UsedRange.Offset(3, 0).EntireRow.Delete
    .[A3:F3].ClearContents
End With
End Sub


============================
作者: PJChen    時間: 2020-4-17 22:18

回復 23# 准提部林

准大好,

不好意思,這個新表格是這幾天才啟用,發現格式沒做好,要更改如下
另外 表格中取出的瓶數及箱數 數值都不正確,我把正確答案列出,也請幫忙修正...再次感謝
[attach]31926[/attach]
[attach]31925[/attach]
作者: PJChen    時間: 2020-4-17 23:00

回復 23# 准提部林

准大,
感謝你,我改好了
作者: PJChen    時間: 2020-6-16 00:15

回復 23# 准提部林

准大,
我修改了這個程式,想讓
HD欄>0,則填入,最後效期sheet的J欄
HE欄>0,則填入,最後效期sheet的K欄
目前只try了HE欄,但無法填入,可以幫我看看嗎?    [attach]32174[/attach]
  1. Sub  最後效期()
  2. Dim Arr, Brr, R&, 統&, N&, BK As Workbook
  3. Set BK = Workbooks("最新庫存.xlsx")
  4. BK.Sheets("最後效期").Activate
  5. Arr = Range([飛比!A1], [飛比!HE65536].End(xlUp))
  6. For R = 4 To UBound(Arr)
  7.     統 = Val(Arr(R, UBound(Arr, 2)))
  8.     If 統 = 0 Then GoTo 101
  9.     N = N + 1
  10.     Arr(N, 11) = Arr(R, 5) '料號
  11. 101: Next R
  12. If N = 0 Then Exit Sub

  14. With [最後效期!A4:H4].Resize(N)
  15.      .Rows(1).Copy .Cells
  16. End With
  17. With [最後效期!L4:AB4].Resize(N)
  18.      .Rows(1).Copy .Cells
  19. End With
  20. End Sub
複製代碼
作者: 准提部林    時間: 2020-6-16 11:23

回復 26# PJChen

你這程式碼根本拿不到任何資料!!!
應該是完全不了解原程式碼的意思, 這樣是無法套用的~~

光是這不成套的程式碼及簡單的說明, 無法了解詳細需求規則,
好像每次的提問, 我幾乎都抓不到要的是什麼???只能用猜,
這總不是辦法, 或許再研究一下提問方式, 讓別人都可了解清楚你的目的!!!
作者: PJChen    時間: 2020-6-16 12:43

本帖最後由 PJChen 於 2020-6-16 12:45 編輯

回復 27# 准提部林

最後效期,A4:H4,L4:AB4原來都有公式,作為動態表格使用,
程式只有做二個動作:
1) 將來源料號填入J:K欄,
2) 最後依據K欄的列數,將A4:H4,L4:AB4的公式下拉即可  
[attach]32178[/attach]
[attach]32177[/attach]
作者: 准提部林    時間: 2020-6-16 15:16

回復 28# PJChen


Sub 最後效期()
Dim Arr, Brr, Crr, R&, i&, N&, BK As Workbook
Set BK = Workbooks("最新庫存.xlsx")
BK.Sheets("最後效期").Activate
R = [飛比!HE65536].End(xlUp).Row
Arr = Sheets("飛比").Range("F1:F" & R)
Brr = Sheets("飛比").Range("HD1:HE" & R)
ReDim Crr(1 To R, 1 To 2)
For i = 4 To R
    If Val(Brr(i, 1)) + Val(Brr(i, 2)) = 0 Then GoTo 101
    N = N + 1
    If Brr(i, 1) > 0 Then Crr(N, 1) = Arr(i, 1)
    If Brr(i, 2) > 0 Then Crr(N, 2) = Arr(i, 1)
101: Next i
If N = 0 Then Exit Sub
With Sheets("最後效期")
    .[J4:K4].Resize(N) = Crr
    If N > 1 Then
      .[L4:AB4].Copy .[L5:AB5].Resize(N - 1)
      .[A4:H4].Copy .[A5:H5].Resize(N - 1)
    End If
End With
End Sub
作者: PJChen    時間: 2020-6-16 16:53

回復 29# 准提部林

准大,
1) 如圖,如何使J欄&K欄資料可以連續,且都從第4列開始載入資料?
2) 請問For i = 4 To R
該如何理解紅字部份?為何是4?
[attach]32180[/attach]
[attach]32179[/attach]
作者: 准提部林    時間: 2020-6-16 19:08

回復 30# PJChen

Sub 最後效期()
Dim Arr, Brr, Crr, R&, i&, j%, N&(1 To 2), NN&, BK As Workbook
'Set BK = Workbooks("最新庫存.xlsx")
'BK.Sheets("最後效期").Activate
R = [飛比!HE65536].End(xlUp).Row
Arr = Sheets("飛比").Range("F1:F" & R)
Brr = Sheets("飛比").Range("HD1:HE" & R)
ReDim Crr(1 To R, 1 To 2)
For i = 4 To R
For j = 1 To 2
    If Val(Brr(i, j)) > 0 Then
       N(j) = N(j) + 1: Crr(N(j), j) = Arr(i, 1)
       If N(j) > NN Then NN = N(j)
    End If
Next j
Next i
If NN = 0 Then Exit Sub
With Sheets("最後效期")
    .[J4:K4].Resize(NN) = Crr
    If NN <= 1 Then Exit Sub
    .[L4:AB4].Copy .[L5:AB5].Resize(NN - 1)
    .[A4:H4].Copy .[A5:H5].Resize(NN - 1)
End With
End Sub
作者: Andy2483    時間: 2022-10-27 10:43

回復 31# 准提部林
'謝謝前輩
'後學在此帖學習到
'1.沒有深入學習得不到精華
'2.習得批次宣告變數且批次數與迴圈搭配使用!初開始只以為少宣告幾個變數
'3.習得 If N(j) > NN Then 取最大數的方法
'4.習得 [J4:K4].Resize(NN) = Crr,以前只會 [J4].Resize(NN,2)
'5.周到的防錯需要再累積經驗!才能辦到
以下心得註解請在指教! 謝謝前輩

Sub 最後效期()
Dim Arr, Brr, Crr, R&, i&, j%, N&(1 To 2), NN&, BK As Workbook
'↑宣告變數
R = [飛比!HE65536].End(xlUp).Row
'↑令R是 HE欄儲存格有內容的最後一列數
Arr = Sheets("飛比").Range("F1:F" & R)
'↑令Arr是陣列 倒入飛比表 的F1到
'F欄的(HE欄儲存格有內容的最後一列數) 的值
Brr = Sheets("飛比").Range("HD1:HE" & R)
'↑令Brr是陣列 倒入飛比表 的HD1到
'HE欄的(HE欄儲存格有內容的最後一列數) 的值
ReDim Crr(1 To R, 1 To 2)
'↑宣告Crr陣列的大小 綜方向 1到 HE欄儲存格有內容的最後一列數
'橫方向 1 到 2
For i = 4 To R
'↑設外順迴圈 從4 到 R
   For j = 1 To 2
   '↑設內順迴圈 從 1 到 2
      If Val(Brr(i, j)) > 0 Then
      '↑如果 惠 統 這兩欄裡的值大於0
         N(j) = N(j) + 1
         '↑N是這兩欄符合If條件次數的變數!初始值是0
         Crr(N(j), j) = Arr(i, 1)
         '↑Crr陣列從第一列開始放入符合條件 的膠帶顏色
         If N(j) > NN Then
         '↑如果大於 NN
         '↑當N(j)=1時,NN的初始值是0 !條件成立
            NN = N(j)
            '↑條件成立!就讓NN =符合If條件次數
            '↑當N(j)=1時 條件成立! NN=1
            '↑後續如果 N(1) N(2)不相等!NN會裝入最大數
         End If
      End If
   Next j
Next i
If NN = 0 Then
'↑如果N()的最大數NN 是0!完全沒有符合條件的資料
   Exit Sub
   '↑結束程序
End If
With Sheets("最後效期")
'↑接下來關於 最後效期表的相關程序(前面有 空白+"."符號的")
    .[J4:K4].Resize(NN) = Crr
    '↑由 最後效期表 的[J4:K4](含)開始向下擴展 NN列的範圍貼入Crr的值
    '雖然 ReDim Crr(1 To R, 1 To 2)宣告的範圍比 最後結果範圍大!
    '但是精準計算!有效Resize擴展結果範圍,就不會影響其他儲存格
    If NN <= 1 Then Exit Sub
    '↑如果N()的最大數NN=1,就 結束程序
    .[L4:AB4].Copy .[L5:AB5].Resize(NN - 1)
    '↑將 最後效期表[L4:AB4]儲存格 複製到
    '最後效期表[L5:AB5](含)開始向下擴展 NN-1列
    .[A4:H4].Copy .[A5:H5].Resize(NN - 1)
    '↑將 最後效期表[A4:H4]儲存格 複製到
    '最後效期表[A5:H5](含)開始向下擴展 NN-1列
End With
End Sub
作者: Andy2483    時間: 2022-10-28 15:12

回復 31# 准提部林
謝謝前輩
後學用兩個陣列+兩個字典處理,請前輩再指導!

Option Explicit
Sub TEST_20221028()
Dim Arr, Brr, i&, j&, X, Y, C, R
R = [飛比!HE65536].End(xlUp).Row
Arr = Sheets("飛比").Range("F1:F" & R)
Brr = Sheets("飛比").Range("HD1:HE" & R)
Set X = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
For i = 4 To R
   If Val(Brr(i, 1)) > 0 Then
      X(Brr(i, 1) & "|" & i) = Arr(i, 1)
   End If
   If Val(Brr(i, 2)) > 0 Then
      Y(Brr(i, 2) & "|" & i) = Arr(i, 1)
   End If
Next
With Sheets("最後效期")
   .[J4:K4].Resize(R).ClearContents
   .[L5:AB5].Resize(R).ClearContents
   .[A5:H5].Resize(R).ClearContents
   If X.Count > 0 Then
      .[J4].Resize(X.Count, 1) = Application.Transpose(X.items)
   End If
   If Y.Count > 0 Then
      .[K4].Resize(Y.Count, 1) = Application.Transpose(Y.items)
   End If
   C = IIf(X.Count >= Y.Count, X.Count, Y.Count)
   If C <= 1 Then Exit Sub
   .[L4:AB4].Copy .[L5:AB5].Resize(C - 1)
   .[A4:H4].Copy .[A5:H5].Resize(C - 1)
End With
End Sub
Sub 清除()
With Sheets("最後效期")
   .[J4:K4].Resize(100).ClearContents
   .[L5:AB5].Resize(100).ClearContents
   .[A5:H5].Resize(100).ClearContents
End With
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)