[發問] 資料分拆問題。

本帖最後由 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後以貼上值的方法新增工作表,則不會將資料來源的格式都複製過去,例如字型及字體大小都不要跟過去。

資料來源:

執行後的結果:

分類要求.zip (9.12 KB)

樓主熱帖

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

2^#

發表於 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

Xl0000051.rar (14.89 KB)

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

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2024-9-23

3^#

發表於 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

複製代碼

TOP

stephenlee

中學生 Rank: 2

帖子: 63
主題: 32
精華: 0
積分: 125
點名: 0
作業系統: WIn10
軟體版本: OFFICE2013
閱讀權限: 20
註冊時間: 2018-7-19
最後登錄: 2022-8-11

4^#

發表於 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 和分類來判斷做整理。

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

分類要求更新.zip (10.78 KB)

TOP

stephenlee