ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

[µo°Ý] ¦p¦ó§Q¥Îªí³æ§@¥X³fªí

[µo°Ý] ¦p¦ó§Q¥Îªí³æ§@¥X³fªí

½Ð±Ð¦U¦ì«e½ú,¦p¦ó§Q¥Îªí³æ§@¥X³fªí,·P®¦.
¥X³f²Î­p.jpg

¥X³f²Î­p.rar (8.48 KB)

§ù¤p¥­

ÀH·NºÛ "EXCEL°g"  blog  ©Îhttps://hcm19522.blogspot.com/ EXCEL¨ç¼Æ

TOP

  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
½Æ»s¥N½X

TOP

¦^´_ 3# ikboy ·PÁÂikboy,µ{¦¡¥i¥Î¨ä¥L¦Û¦æ­×¹¢,¦]¥\¤O¤£¨¬,¬O§_¯à±Nµ{¦¡¥\¯àµù¸Ñ,Åý¤p§Ì¾Ç²ß.
§ù¤p¥­

TOP

¦^´_ 4# dou10801
  1. Sub zz()
  2. Dim a, Title, b(), c&, n&, k&, r&, t&
  3. Title = [b2:f2].Value   '¨ú¼ÐÃD
  4. c = UBound(Title, 2)    '¨ú¼ÐÃDªø«×
  5. a = [b2].CurrentRegion.Value '¨úªí1ªº¸ê®Æ©ñ¤J a Array
  6. t = UBound(a, 2) / c - 1    '­pºâªí1¤¤¼ÐÃDªº­«½Æ¦¸¼Æ ¥H 0 ¶}©l¦Ü t, ¬°¥H¤U²Ä¤@´`Àô§@¦n­pºâ ,½Ð¬Ý @_@
  7. ReDim b(1 To UBound(a) * (t + 1), 1 To c + 1)   '«Ø¥ß¤@­Ó¸û¤jªº b Array
  8. For n = 0 To t  '@_@
  9.     k = n * c + c   '­pºâ k ªº­È, §Y¥X³f¼Æ¶q¦bTitle¤¤ªº¦ì¸m
  10.     For i = 2 To UBound(a)  '¥Ñ a ªº²Ä2¦æ´`Àô
  11.         If a(i, k) Then '¦æ¦C¹ïÀ³¦³¥X³f¼Æ¶q, ¶i¦æ¥H¤Uµ{§Ç
  12.             r = r + 1   '«Ø¥ß·s¦æ¼Æµ¹ b Array
  13.             For j = 1 To c  '´`Àô¼ÐÃDªø«×
  14.                 b(r, j) = a(i, k - c + j)   '¨ú a Array ¤¤¬Û¹ï¦æ¦Cªº¸ê®Æµ¹ b Array
  15.             Next            '´`Àô
  16.             b(r, c + 1) = b(r, 4) * b(r, 5) '­pºâª÷ÃB
  17.         End If
  18.     Next    '´`Àô
  19. Next    '´`Àô
  20. Workbooks.Add 1 '·s«Ø¤u§@ï
  21. [a1].Resize(1, c) = Title   '¼g¤J¼ÐÃD
  22. Cells(1, c + 1) = "Amount" '¼g¤J·s¼ÐÃD
  23. [a2].Resize(r, c + 1) = b   '±N b Array ¼g¤J
  24. [a1].CurrentRegion.Borders.Value = 1    'µe¤W®æ½u
  25. End Sub
½Æ»s¥N½X

TOP

¦^´_ 5# ikboy ikboy¤j¤j,·P®¦.
§ù¤p¥­

TOP

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾Ç¶X¤u§@ªÅÀÉÂǦ¹©«½m²ß°}¦C,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

¸ê®Æªí:
20230726_1.jpg
2023-7-26 14:18


·s¼W¬¡­¶Ã¯©Ò§e²{ªº°õ¦æµ²ªG:
20230726_2.jpg
2023-7-26 14:19



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) = "ª÷ÃB"
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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

©T©w¤Q¶µ©¹¥k«Ø¥ß E19:H21=OFFSET($B$2,MOD($D19-1,10)+1,INT(($D19-1)/10)*5+COLUMN(A1))
ÀH·NºÛ "EXCEL°g"  blog  ©Îhttps://hcm19522.blogspot.com/ EXCEL¨ç¼Æ

TOP

¦^´_ 1# dou10801


Sub test()
Set s = Sheets("¤u§@ªí1"): Set s2 = Sheets("¤u§@ªí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 <--¤G¤¸¤@¦¸Áp¥ß¤èµ{y=ax+b¥N¤J¨D-> 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 ¶µ¦¸,[«~   ¦W],®e¶qkg,°â»ù,¥X³f¼Æ¶q,°â»ù*¥X³f¼Æ¶q as ª÷ÃB  from[¤u§@ªí2$H1:L] where ¥X³f¼Æ¶q is not null"
Set rs = cn.Execute(q): s2.[A1:E1] = s.[b2:F2].Value: s2.[F1] = "ª÷ÃB": s2.[A2].CopyFromRecordset rs
q = "select sum(¥X³f¼Æ¶q) as ¥X³f¼Æ¶q ,sum(ª÷ÃB) as ª÷ÃB from[¤u§@ªí2$E1:F]"
Set rs = cn.Execute(q): r = s2.Cells(Rows.Count, "F").End(3).Row + 1
s2.Cells(r, "D") = "¦X­p": s2.Cells(r, "E").CopyFromRecordset rs
End Sub

TOP

        ÀR«ä¦Û¦b : ¬°¤H³B¥@­n¤p¤ß²Ó¤ß¡A¦ý¤£­n¡u¤p¤ß²´¡v¡C
ªð¦^¦Cªí ¤W¤@¥DÃD