麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 資料分拆問題。 [打印本頁]

作者: stephenlee 時間: 2021-1-23 11:31 標題: 資料分拆問題。

本帖最後由 stephenlee 於 2021-1-23 11:34 編輯

請問各位高手,如何用VBA 做以下要求,非常感謝

A至F 是資料來源, H至N 欄是我做例子說明的資料, 平時不會存在在Excel 內, 只有A欄至F欄資料而已, 同時資料有時有多有少,A欄為空白。
當中B欄和F欄我要對應進行分拆數量,例如如果該行的ITEM 為SC1 , 則 D欄QTY 那要分拆數量為要求的數量, 例如II欄對應的拆數要求為900
那D2 便要分拆900出來,除了QTY要分拆數量外,其他資料不變.但D2因為多於900, 所以新增行數去分拆數量出來,另外也要對應分類 K欄的資料, 如果 F欄的分類是3的話
要自動懂用我例子所示,懂分三個組合去合成D欄QTY的數量

例如 F2= 3 個分類即是 = 3個組合每個組合要分拆組合成D2 的數量

當分拆數量後,自動在A 欄 "Page" 填上 1,2 , 或者 3,4 , 或者5 或者Support這樣。

資料來源不變, 當我執行VBA 後,他會將運算結果以新增一張工作表顯示結果,例如Sheet2 這樣。

每次當我將資料複製至Sheet1 的A欄至F欄後, 執行VBA 則每次都新增一張工作表顯示結果出來。

執行VBA後以貼上值的方法新增工作表,則不會將資料來源的格式都複製過去,例如字型及字體大小都不要跟過去。

資料來源:

[attach]32995[/attach]

執行後的結果:

[attach]32996[/attach]

[attach]32997[/attach]

作者: 准提部林 時間: 2021-1-23 17:38

Sub TEST_A01()
Dim Arr, Brr, i&, j%, k%, X%, V1&, V2&, N&
Arr = Sheets("Sheet1").UsedRange
ReDim Brr(1 To 20000, 1 To 6)
For X = 1 To 6: Brr(1, X) = Arr(1, X): Next
For i = 2 To UBound(Arr)
V1 = Int((Arr(i, 4) - 1) / Arr(i, 9))
V2 = Arr(i, 4) - V1 * Arr(i, 9)
For j = 12 To UBound(Arr, 2)
      If Arr(i, j) = "" Then GoTo j01
      For k = 1 To V1 + 1
         N = N + 1
         For X = 2 To 6: Brr(N + 1, X) = Arr(i, X): Next
         Brr(N + 1, 1) = Arr(i, j)
         Brr(N + 1, 4) = IIf(k > V1, V2, Arr(i, 9))
      Next k
j01: Next j
Next i
With Sheets.Add
   .[A1].Resize(N + 1, 6) = Brr
   .Name = Format(Now, "yyyymmdd-hhmmss")
End With
End Sub

[attach]32998[/attach]

========================

作者: 軒云熊 時間: 2021-1-24 18:54

本帖最後由軒云熊於 2021-1-24 18:56 編輯

回復 1# stephenlee
參考了準大的寫法順便練習有空的話也順便幫我看看是否正常感謝

Public Sub 資料分拆練習()
Application.ScreenUpdating = False
Arr = [A1].CurrentRegion
Ar = [{900, "1,2", "3,4", "5"; 900, "1,2", "3,4","-"; 1800, "Support","-","-"}]
Sheets.Add(After:=Sheets(1)).Name = "結果" & Format(Now, "-YYYY-MM-DD")
For Y = 1 To UBound(Arr, 2): Cells(1, Y) = Arr(1, Y): Next Y
For X = 1 To UBound(Ar)
A = Int(Arr(2 + k, 4) / Ar(X, 1)) + 1
C = Arr(2 + k, 4) - (A - 1) * Ar(X, 1)
For i = 2 To UBound(Ar, 2)
If Ar(X, i) <> "-" Then
For Y = 1 To A
If u < A Then u = u + 1
E = IIf(u = A, C, Ar(X, 1))
Cells(2 + G, 1) = Ar(X, i)
Cells(2 + G, 2) = Arr(2 + k, 2)
Cells(2 + G, 3) = Arr(2 + k, 3)
Cells(2 + G, 4) = E
Cells(2 + G, 5) = Arr(2 + k, 5)
Cells(2 + G, 6) = Arr(2 + k, 6)
G = G + 1
Next Y
End If
u = 0
Next i
k = k + 1
Next X
Application.ScreenUpdating = True
End Sub

複製代碼

作者: stephenlee 時間: 2021-1-26 11:46

Sub TEST_A01()
Dim Arr, Brr, i&, j%, k%, X%, V1&, V2&, N&
Arr = Sheets("Sheet1").UsedRange
ReDim ...
准提部林發表於 2021-1-23 17:38

謝謝准大幫忙,經測試是完全OK的。

不過不好意思.我忘了說 H到N那, 的組合不是固定的

例如 SC1 拆數一定是 900 , SC2 拆數一定是900,SC3 拆數一定是 1800, 但他的組合不是 SC1 鎖定了分類第 3 , 而SC2 不是鎖定了是第2, 不過SC3 就必定是1 。

例如 SC1 的分類可以去 2 , 就是 1,2 和 3.4 。而SC2 的分類可以去 3, 就是 1,2 + 3,4 +5

而SC3 則一直不變。

而SC2和SC3 未必每次都有資料, 所以跟拆數後也要跟分類來新增行數。

而做法都是跟之前要求一樣,填上資料後,根據數量及分類執行再以新一個工作表顯示。只不過是按照每次所填上的Item 和分類來判斷做整理。

特別不好意思,再麻煩你。非常感激你的細心幫忙。謝謝

[attach]33007[/attach]

作者: stephenlee 時間: 2021-1-26 11:47

回復 stephenlee
參考了準大的寫法順便練習有空的話也順便幫我看看是否正常感謝
軒云熊發表於 2021-1-24 18:54

謝謝大大細心幫忙,非常感謝, 經測試都是ok的,不過我需要再更新內容,所以就不好意思再麻煩你了。謝謝

作者: 准提部林 時間: 2021-1-26 14:45

回復 4# stephenlee

item 只有這三種???
而分類最多是3???

其實事先在H:N輸入要分拆的資料就可以? 沒有的資料它也不會跑出來

作者: 准提部林 時間: 2021-1-26 15:11

回復 4# stephenlee

參考看看:
[attach]33008[/attach]

作者: stephenlee 時間: 2021-1-26 17:33

回復 stephenlee

item 只有這三種???
而分類最多是3???

其實事先在H:N輸入要分拆的資料就可以? ...
准提部林發表於 2021-1-26 14:45

是的,只有三個ITEM, 再次感謝准大,。

作者: stephenlee 時間: 2021-1-26 17:47

回復 stephenlee

參考看看:
准提部林發表於 2021-1-26 15:11

完全符合要求內容,不好意思一直麻煩你。
非常感謝閣下一直幫忙,而且非常快地幫了我解決問題,幫我節省了很多時間。再次感謝。

作者: 軒云熊 時間: 2021-1-26 20:28

回復 5# stephenlee

不是我在麻煩你是我借你的題目來學習浪費了你寶貴的時間我感到抱歉謝謝你幫我測試感恩

作者: Andy2483 時間: 2023-11-21 08:03

本帖最後由 Andy2483 於 2023-11-21 10:04 編輯

回復 2# 准提部林

謝謝論壇,謝謝前輩指導
後學藉此帖學習前輩的方案,以下是心得註解,請前輩再指導

Sub TEST_A01()
Dim Arr, Brr, i&, V1&, V2&, N&, j%, k%, x%
'↑宣告變數:(Arr, Brr)通用型,(i,V1,V2,N)長整數,(j,k,x)短整數
Arr = Sheets("Sheet1").UsedRange
'↑令Arr變數是二維陣列,以儲存格值帶入陣列中
ReDim Brr(1 To 20000, 1 To 6)
'↑宣告Brr變數是二維空陣列,縱向1~20000,橫向1~6
For x = 1 To 6: Brr(1, x) = Arr(1, x): Next
'↑設順迴圈!x從1~6,將Arr陣列第1列資料帶入 Brr陣列第1列中
For i = 2 To UBound(Arr)
'↑設順迴圈!i從2到 Arr陣列縱向最大索引列號
V1 = Int((Arr(i, 4) - 1) / Arr(i, 9))
'↑令V1變數是 (i迴圈列4欄Arr陣列值-1)除以 i迴圈列9欄Arr陣列值,
'最後去除小數的整數
V2 = Arr(i, 4) - V1 * Arr(i, 9)
'↑令V2變數是 i迴圈列4欄Arr陣列值-(V1變數*i迴圈列9欄Arr陣列值)
For j = 12 To UBound(Arr, 2)
'↑設順迴圈!j從12到 Arr陣列橫向最大索引欄號
      If Arr(i, j) = "" Then GoTo j01
      '↑如果i迴圈列j迴圈欄Arr陣列值是空字元?
      'True就跳到標示j01位置繼續執行
      For k = 1 To V1 + 1
      '↑設順迴圈!k從1 到(V1變數+1)
         N = N + 1
         '↑令N變數累加1
         For x = 2 To 6: Brr(N + 1, x) = Arr(i, x): Next
         '↑將Arr陣列i迴圈列(2~6)欄資料帶入 Brr陣列下方空白列
         Brr(N + 1, 1) = Arr(i, j)
         '↑令(N+1)列第1欄Brr陣列值是 i迴圈列j迴圈欄Arr陣列值
         Brr(N + 1, 4) = IIf(k > V1, V2, Arr(i, 9))
         '↑令(N+1)列第4欄Brr陣列值是 IIF()回傳值:
         '如果k變數大於V1變數,回傳V2變數,
         '否則回傳 i迴圈列9欄Arr陣列值
      Next k
j01: Next j
Next i
With Sheets.Add
'↑以下是關於新增一個工作表後的程序
   .[A1].Resize(N + 1, 6) = Brr
   '↑令該新表[A1]擴展向下(N+1)列,向右擴展6欄儲存格值以Brr陣列帶入
   .Name = Format(Now, "yyyymmdd-hhmmss")
   '↑令該新表表名是當下時間經格式化為指定文字格式的字串
End With
End Sub
'=================================================
'以下是字典,Do Until的練習,請前輩再指導
Option Explicit
Sub TEST()
Dim Brr, Crr, Arr, V&, V2&, Z, i&, j%, R&, c%, T$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect(Sheet2.UsedRange, [H:IV])
For i = 2 To UBound(Brr): Z(Brr(i, 1)) = i: Next
Crr = Range([F1], [B65536].End(3)(1, 0))
ReDim Arr(20000, 1 To 6)
For j = 1 To 6: Arr(0, j) = Crr(1, j): Next
For i = 2 To UBound(Crr)
T = Crr(i, 2): Z(T & "qty") = Val(Crr(i, 4))
V2 = Brr(Z(T), 2): c = 0
Do Until c = Brr(Z(T), 4)
   V = Z(T & "qty")
   Do Until V < 0
      R = R + 1
      For j = 2 To 6: Arr(R, j) = Crr(i, j): Next
      Arr(R, 1) = Brr(Z(T), 5 + c)
      Arr(R, 4) = IIf(V - V2 > 0, V2, V)
      V = V - V2
   Loop
   c = c + 1
Loop
Next
With Sheets.Add
.[A1].Resize(R + 1, 6) = Arr
.Name = Format(Now, "yyyymmdd-hhmmss")
End With
End Sub

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