- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
4#
發表於 2022-10-4 16:47
| 只看該作者
回復 3# adam2010
謝謝前輩回覆
請前輩先試看看
1.轉置方式是否適合
2.攤平方式是否適用
今天習得 資料轉置,攤平天數
練習陣列- Option Explicit
- Sub 資料轉置()
- Dim Brr, Crr, c&, i&, j&, x&, xR, R, T, v, Y, Z, xA, Sc&, Sr&
- Dim B#, K%, P$, Q, Ra, Rs, Rn, n&, Avgd&, Avgv
- Set xA = ActiveSheet.Cells
- Set Y = CreateObject("Scripting.Dictionary")
- For Each Ra In xA.SpecialCells(2)
- R = Ra.Address
- Rn = IIf(Ra = "總計" And Rn = "" And Rs <> "", Ra.Address, Rn)
- Rs = IIf(Ra = "總計" And Rs = "", Ra.Address, Rs)
- Next
- Brr = xA.Range(Rs, Rn)
- Rs = Brr(1, 8)
- Rn = Brr(1, UBound(Brr, 2) - 1)
- Sc = Rn - Rs + 1 '天數
- Sr = UBound(Brr) - 2 '品號數
- ReDim Crr(1 To Sc * Sr, 1 To 13)
- For j = 2 To Sr + 1
- For i = 1 To Sc
- n = n + 1
- Crr((j - 2) * Sc + i, 1) = n
- Crr((j - 2) * Sc + i, 2) = Rs + (i - 1)
- Crr((j - 2) * Sc + i, 13) = Brr(j, UBound(Brr, 2))
- For x = 1 To 7
- Crr(n, x + 2) = Brr(j, x)
- Next
-
- For x = 8 To UBound(Brr, 2) - 1
- If Brr(1, x) = Rs + (i - 1) Then
- Crr((j - 2) * Sc + i, 12) = Brr(j, x)
- End If
- Next
- Next
- Next
- For j = n To 1 Step -1
- If Crr(j, 12) > 0 Then
- For i = j - 1 To 1 Step -1
- If Crr(i, 12) > 0 Or Crr(i, 3) <> Crr(j, 3) Or i = 1 Then
- Avgd = j - i
- If Avgd > 0 Then
- Avgv = Crr(j, 12) / Avgd
- End If
- If Crr(1, 12) = "" And i = 1 Then
- Avgd = j - i + 1
- If Avgd > 0 Then
- Avgv = Crr(j, 12) / Avgd
- End If
- End If
- Exit For
- End If
- Next
- End If
- Crr(j, 10) = Avgd
- Crr(j, 11) = Avgv
- If j > 1 Then
- Avgd = IIf(Crr(j, 3) = Crr(j - 1, 3), Avgd, 0)
- Avgv = IIf(Crr(j, 3) = Crr(j - 1, 3), Avgv, 0)
- End If
- Next
- If Crr(1, 12) <> "" Then
- Crr(1, 10) = 1
- Crr(1, 11) = Crr(1, 12)
- End If
- Workbooks.Add
- [A1].Resize(1, 13) = Split("NO/日期/料號/吋/摻/可用庫存/1300/" _
- & "在制量/Var/攤平天數/攤平數量/訂單數量/總計", "/")
- [A2].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
- Cells.Columns.AutoFit
- Cells.Rows.AutoFit
- Cells.Columns.AutoFit
- [2:2].Select
- ActiveWindow.FreezePanes = True
- [1:1].AutoFilter
- [A1].Select
- Cells.Borders.LineStyle = xlContinuous
- End Sub
|
|
