Board logo

標題: [發問] 如何利用表單作出貨表 [打印本頁]
作者: dou10801    時間: 2021-1-4 09:04     標題: 如何利用表單作出貨表

請教各位前輩,如何利用表單作出貨表,感恩.
作者: hcm19522    時間: 2021-1-4 10:06

https://blog.xuite.net/hcm19522/twblog/589540468
作者: ikboy    時間: 2021-1-4 11:17

  1. Sub zz()
  2. Dim a, Title, b(), c&, n&, k&, r&, t&
  3. Title = [b2:f2].Value
  4. c = UBound(Title, 2)
  5. a = [b2].CurrentRegion.Value
  6. t = UBound(a, 2) / c - 1
  7. ReDim b(1 To UBound(a) * (t + 1), 1 To c + 1)
  8. For n = 0 To t
  9.     k = n * c + c
  10.     For i = 2 To UBound(a)
  11.         If a(i, k) Then
  12.             r = r + 1
  13.             For j = 1 To c
  14.                 b(r, j) = a(i, k - c + j)
  15.             Next
  16.             b(r, c + 1) = b(r, 4) * b(r, 5)
  17.         End If
  18.     Next
  19. Next
  20. Workbooks.Add 1
  21. [a1].Resize(1, c) = Title
  22. Cells(1, c + 1) = "Amount"
  23. [a2].Resize(r, c + 1) = b
  24. [a1].CurrentRegion.Borders.Value = 1
  25. End Sub
複製代碼
作者: dou10801    時間: 2021-1-4 13:26

回復 3# ikboy 感謝ikboy,程式可用其他自行修飾,因功力不足,是否能將程式功能註解,讓小弟學習.
作者: ikboy    時間: 2021-1-4 16:44

回復 4# dou10801
  1. Sub zz()
  2. Dim a, Title, b(), c&, n&, k&, r&, t&
  3. Title = [b2:f2].Value   '取標題
  4. c = UBound(Title, 2)    '取標題長度
  5. a = [b2].CurrentRegion.Value '取表1的資料放入 a Array
  6. t = UBound(a, 2) / c - 1    '計算表1中標題的重複次數 以 0 開始至 t, 為以下第一循環作好計算 ,請看 @_@
  7. ReDim b(1 To UBound(a) * (t + 1), 1 To c + 1)   '建立一個較大的 b Array
  8. For n = 0 To t  '@_@
  9.     k = n * c + c   '計算 k 的值, 即出貨數量在Title中的位置
  10.     For i = 2 To UBound(a)  '由 a 的第2行循環
  11.         If a(i, k) Then '行列對應有出貨數量, 進行以下程序
  12.             r = r + 1   '建立新行數給 b Array
  13.             For j = 1 To c  '循環標題長度
  14.                 b(r, j) = a(i, k - c + j)   '取 a Array 中相對行列的資料給 b Array
  15.             Next            '循環
  16.             b(r, c + 1) = b(r, 4) * b(r, 5) '計算金額
  17.         End If
  18.     Next    '循環
  19. Next    '循環
  20. Workbooks.Add 1 '新建工作簿
  21. [a1].Resize(1, c) = Title   '寫入標題
  22. Cells(1, c + 1) = "Amount" '寫入新標題
  23. [a2].Resize(r, c + 1) = b   '將 b Array 寫入
  24. [a1].CurrentRegion.Borders.Value = 1    '畫上格線
  25. End Sub
複製代碼
作者: dou10801    時間: 2021-1-5 07:57

回復 5# ikboy ikboy大大,感恩.
作者: Andy2483    時間: 2023-7-26 14:20

謝謝論壇,謝謝各位前輩
後學趁工作空檔藉此帖練習陣列,學習方案如下,請各位前輩指教

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

新增活頁簿所呈現的執行結果:
[attach]36747[/attach]


Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(1 To 1000, 1 To 6), i&, j%, R&, n%, xA As Range
Arr = [B2:G2]: Arr(1, 6) = "金額"
Set xA = [B3:H12]
For n = 0 To [B2].CurrentRegion.Columns.Count \ 5 - 1
   Brr = xA.Offset(0, 5 * n)
   For i = 1 To UBound(Brr)
      If Val(Brr(i, 5)) = 0 Then GoTo i01
      R = R + 1
      For j = 1 To 5: Crr(R, j) = Brr(i, j): Next
i01: Next
Next
If R = 0 Then Exit Sub
With Workbooks.Add.Sheets(1)
   .[A1].Resize(1, 6) = Arr
   With .[A2].Resize(R + 1, 6)
      .Value = Crr
      .Columns(6) = "=D2*E2"
      .Cells(R + 1, 5).Resize(1, 2) = "=SUM(E2:E" & R + 1 & ")"
   End With
   .[A1].CurrentRegion.Borders.Value = 1
End With
Set xA = Nothing: Erase Arr, Brr, Crr
End Sub
作者: hcm19522    時間: 2023-7-31 12:24

固定十項往右建立 E19:H21=OFFSET($B$2,MOD($D19-1,10)+1,INT(($D19-1)/10)*5+COLUMN(A1))
作者: singo1232001    時間: 2023-7-31 15:08

回復 1# dou10801


Sub test()
Set s = Sheets("工作表1"): Set s2 = Sheets("工作表2"): s2.Cells.ClearContents
c = UBound(s.[b2].CurrentRegion.Value2, 2) / 5
ReDim ar(1 To c): s2.[H1:L1] = s.[b2:F2].Value
For i = 1 To c
s2.Cells(10 * i - 8, 8).Resize(10, 5) = s.Cells(3, 5 * i - 3).Resize(10, 5).Value
Next  'y=10x-8 <--二元一次聯立方程y=ax+b代入求-> y=5x-3
Set cn = CreateObject("adodb.connection"): V = Application.Version
If V >= 12 Then V = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0; "
If V < 12 Then V = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0; "
cn.Open V & "Data Source=" & ThisWorkbook.FullName
q = "select 項次,[品   名],容量kg,售價,出貨數量,售價*出貨數量 as 金額  from[工作表2$H1:L] where 出貨數量 is not null"
Set rs = cn.Execute(q): s2.[A1:E1] = s.[b2:F2].Value: s2.[F1] = "金額": s2.[A2].CopyFromRecordset rs
q = "select sum(出貨數量) as 出貨數量 ,sum(金額) as 金額 from[工作表2$E1:F]"
Set rs = cn.Execute(q): r = s2.Cells(Rows.Count, "F").End(3).Row + 1
s2.Cells(r, "D") = "合計": s2.Cells(r, "E").CopyFromRecordset rs
End Sub



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