Board logo

標題: [發問] 多個條件數量分拆及隔行。 [打印本頁]
作者: stephenlee    時間: 2021-3-12 01:10     標題: 多個條件數量分拆及隔行。

本帖最後由 stephenlee 於 2021-3-12 01:11 編輯

第一個工作表是資料, 而L欄和M欄 是要根據item 來做拆數要求, 平時L和M欄是沒有資料的,我打上去是為作說明。

A欄至I欄是資料,但我要根據D欄 item 這個項目來做分拆數量及隔行。 (拆數和隔行的結果以新增一張工作表作顯示)

最主要根據D欄及E欄來分析要拆的要求。

例如 item 為 044  要拆 1000  , 050 要拆2000 ,055 要拆1500 的數量。
餘數在100 內可以不用拆數,而沒有超過拆數要求的數量,則完全不用做動作,資料照舊。


例如044   


如果剛好1000 就不用做任何動作, 少於1000都是。

2100   就拆  1 至1000=1000,  1001至2100=1100   

2105   就拆  1至1000=1000,   1001至2000=1000,  2001至2105=105 , 因餘數超過100, 所以當新一個數量,   


當判斷D欄為item 是什麼後,再根據E欄的數量要做分拆動作。

做完之後再做隔行動作, 因我要做郵件合併功能在Word 內,要根據group 做分隔。(郵件合併是一張A4 Size, 打橫的,有4個大格,
每個格都為一筆資料,即是4列,所以要把不同group分開,不能混在一起。)

如果group 1 有4行 就不用隔行,貼著group 2 ,如果group 2 為3行,即要新增一行,與group 3分開



每4筆資料為一組, 以4為單位。

不滿4的就新增列數為4, 同時要滿足group是要在一起的。

例如 處理後的資料group 1,當我拆完數後所得出的列數是19列,所以要加一行 變成 20 列。

如果做完拆數例如group 2 我得出有6列,所以要加2列成8。

如果做完group 分拆數後, 剛好是4, 那麼便不用新增列數。
否則都要新增列數至最接近的4倍數列數。

同時item 那不一定是同時間有5個item 有時候是1個,有時候是3個。

總之是要根據item 那的拆數要求拆數量和E欄看數量是否有超過就做動作,拆完數量再用group那的資料做隔行。

暫時有5個item 要拆數, 另外是否可以再設定可以將來如果多於5個item ,例如第6個item 要拆另外一個數量,是不是可以
額外再增加,另外d欄至i 是一個群組,如果我有更多資料要在D欄前插入,那麼位置有變動,d欄和i欄是固定名稱資料是不會有特別更改,固定6欄
,但如果我新增了三欄那麼d欄至i欄各會退後3欄,如果我想再做分拆數量和隔行,這個可不可以做到(附表1), 如何設定?


如果不行的話,先使用5個item 就可以。



不好意思,很長文,這個很難操作,所以看各位可否幫忙。在此跪謝各位。



[attach]33120[/attach]
作者: jcchiang    時間: 2021-3-12 12:48

回復 1# stephenlee


試試看,寫不好,再看有沒有高手出手
另外050不是2000分拆嗎??,為何你的範例第一組2000分拆,第二組又變成2100分拆(第二組值剛好為2100,所以範例沒分拆)

Sub ex()
Dim X%, Y%, K%, Z%, Count%, Check$, a As Object, d As Object
Set d = CreateObject("Scripting.Dictionary")
Sheets("附表1").UsedRange.ClearContents
Sheets("附表1").[a1:L1] = Array("Line", "RP", "CP", "job 1", "job 2", "job 3", "item", " ", "f", "t", "QTY", "group")
For Each a In Sheets("要處理的資料").Range([L2], [L2].End(4))
   d(a.Value) = a.Offset(, 1)
Next
For Each a In Sheets("要處理的資料").Range([D2], [D65535].End(3))
   If Check = "" Then
      Check = a.Value
   ElseIf Check <> a.Value Then
      Z = 4 - (Count Mod 4)
      Count = 0
      Check = a.Value
   End If
   If d.exists(a.Value) Then
      With Sheets("附表1")
         K = 1: X = 0
         If a.Offset(, 1) > d(a.Value) Then
            For Y = 1 To WorksheetFunction.Quotient(a.Offset(, 1), d(a.Value))
               a.Offset(, -3).Resize(, 3).Copy .[a65535].End(3).Offset(1 + Z).Resize(, 3)
               .[g65535].End(3).Offset(1 + Z).Resize(, 6) = Array(a, a.Offset(, 1), K, X + d(a.Value), d(a.Value), a.Offset(, 5))
               K = .[I65535].End(3) + d(a.Value)
               X = .[J65535].End(3)
               Z = 0
            Next
               a.Offset(, -3).Resize(, 3).Copy .[a65535].End(3).Offset(1 + Z).Resize(, 3)
               .[g65535].End(3).Offset(1 + Z).Resize(, 6) = Array(a, a.Offset(, 1), d(a.Value) + .[I65535].End(3), a.Offset(, 1), a.Offset(, 1) Mod d(a.Value), a.Offset(, 5))
               Count = Y + Count
         Else
            a.Offset(, -3).Resize(, 3).Copy .[a65535].End(3).Offset(1 + Z).Resize(, 3)
            .[g65535].End(3).Offset(1 + Z).Resize(, 6) = Array(a, a.Offset(, 1), 1, a.Offset(, 1), a.Offset(, 1), a.Offset(, 5))
            Count = Count + 1
            Z = 0
         End If
      End With
   End If
Next
Set d = Nothing
End Sub
作者: 准提部林    時間: 2021-3-13 10:34

本帖最後由 准提部林 於 2021-3-13 10:36 編輯

1) 平時L和M欄是沒有資料的,我打上去是為作說明???
__也就是根本沒有L/M欄資料, 各ITEM數量是固定的, 要由程式去寫定???

2) 如果新增了三欄那麼d:i欄各會退後3欄,如果我想再做分拆數量和隔行,這個可不可以做到(附表1), 如何設定?
__結果表欄數依照資料表欄數, 還是不理會那多出來的3欄???

3) ITEM 是固定排在一起的??? 而不是亂序.
作者: stephenlee    時間: 2021-3-13 13:44

本帖最後由 stephenlee 於 2021-3-13 13:54 編輯
1) 平時L和M欄是沒有資料的,我打上去是為作說明???
__也就是根本沒有L/M欄資料, 各ITEM數量是固定的, 要由 ...
准提部林 發表於 2021-3-13 10:34



1) 平時L和M欄是沒有資料的,我打上去是為作說明???
__也就是根本沒有L/M欄資料, 各ITEM數量是固定的, 要由程式去寫定???

是的,檔案是不會有 這些item 的拆數要求顯示的,只是我打在那方便我說明,本身要靠VBA 去認是那個item 對應要拆多少數。


2) 如果新增了三欄那麼d:i欄各會退後3欄,如果我想再做分拆數量和隔行,這個可不可以做到(附表1), 如何設定?
__結果表欄數依照資料表欄數, 還是不理會那多出來的3欄???

意思是,我現在有這個"要處理的資料",工作表。資料由A欄至I欄。 要做拆數和分隔行數。

假設我還有另外一個活頁簿內的 另外一張工作表,都是要做拆數和分隔行數,想除了這個"要處理的資料" 做一個版本外。

可以讓我可以把大約這樣的方法套用至另外一個活頁簿的另外一張工作表,同時D欄至I欄 這6欄的欄位名稱
必定是固定,也就是一個群組,而是資料不同,除了E欄沒有欄位名稱外。

例設我在"要處理的資料",由D欄開始插入三欄,那麼本身的D欄至I欄就會後退三欄, 而插入三欄後,都要做到拆數和分隔行數。



但因插了三欄所以位置跳動了,所以想有一個版本可以靈活一點。
例如"附表1 資料" 是另外一個活頁簿的另外一張工作表,但在群組前新增了三欄,不過都是要做分拆數量和分隔行數, 如結果"附表1 結果"

而都有時候不是插入三欄,可能1-2欄,數字不確定,按情況需要。 但那6個群組必定在一起。


3) ITEM 是固定排在一起的??? 而不是亂序.
item 那是好像2那樣,可能會有多有少,同時也要新增或減少item 和對應分別的拆數數量。,暫時最多5個item ,最少 2個而已

太感謝了。

[attach]33122[/attach]
作者: stephenlee    時間: 2021-3-13 16:49

備注一下: 附表1 資料和附表1 結果 只是另外一個活頁簿的資料 2個工作表。我是作說明而新增。

平時必定只有1個工作表,"要處理的資料"那一頁, 而每次處理後,我會刪除新增結果的那張工作表。
作者: 軒云熊    時間: 2021-3-13 22:57

本帖最後由 軒云熊 於 2021-3-13 23:05 編輯

回復 5# stephenlee
有參考準大寫過的拆分方法 但我沒有用字典 因為還不是很熟悉
有空也幫我試試看 是不是你要的 感謝
[attach]33126[/attach]
作者: 軒云熊    時間: 2021-3-14 22:35

回復 5# stephenlee

剛才發現 小於100不分有問題 改了一下  有空再幫我試試看是否正確 感謝
item  有增加的時候 拆分數也會增加嗎?  插入欄位有沒有規則?
[attach]33129[/attach]
作者: stephenlee    時間: 2021-3-15 08:25

回復  stephenlee

剛才發現 小於100不分有問題 改了一下  有空再幫我試試看是否正確 感謝
item  有增加 ...
軒云熊 發表於 2021-3-14 22:35



跪謝大大,現在初步試了一下,暫時滿足要求,待我再深入做一下,再來看是否要再麻煩,非常感激大大花時間幫忙。非常感謝
作者: Andy2483    時間: 2023-11-9 15:36

本帖最後由 Andy2483 於 2023-11-9 15:47 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖以1#範例檔(question1.zip) 練習陣列.字典與邏輯值運算,學習方案如下,請各位前輩指教

資料表:
[attach]36988[/attach]

執行結果:
[attach]36989[/attach]


Option Explicit
Sub TEST()
Dim Brr, Crr, Z, V&, Q&, R&, i&, ii&, j%, T$, T1$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([M2], [L65536].End(xlUp))
For i = 1 To UBound(Brr):  Z(Format(Brr(i, 1), "000")) = Val(Brr(i, 2)): Next
Brr = Range([I1], [A65536].End(xlUp)(2))
ReDim Crr(1 To 10000, 1 To 9)
For j = 1 To 9: Crr(1, j) = Brr(1, j): Next:  R = 1
For i = 2 To UBound(Brr) - 1
   T = Format(Brr(i, 4), "000"):   T1 = Format(Brr(i + 1, 4), "000")
   V = Z(T):     Q = Brr(i, 8)
   For ii = 0 To Q \ V
      R = R + 1
      For j = 1 To 9: Crr(R, j) = Brr(i, j): Next
      Crr(R, 4) = "'" & T
      Crr(R, 6) = V * ii + 1
      Crr(R, 7) = V * (ii - (ii <> Q \ V)) - (ii = Q \ V) * (Q Mod V)
      Crr(R, 8) = V * -(ii <> Q \ V) - (ii = Q \ V) * (Q Mod V)
   Next
   If T <> T1 Then R = (((R - 1) \ 4) - ((R - 1) Mod 4 <> 0)) * 4 + 1
Next
Workbooks.Add
[A1].Resize(R, 9) = Crr
Set Z = Nothing: Erase Brr, Crr
End Sub



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