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

[µo°Ý] ¦p¦ó¿é¤J¨â­Ó¸ê®Æ¦ÛÁ`ªí¤¤¿z¥X¸ê®Æ¡A¿é¤J¦b¥t¤@¤À­¶

[µo°Ý] ¦p¦ó¿é¤J¨â­Ó¸ê®Æ¦ÛÁ`ªí¤¤¿z¥X¸ê®Æ¡A¿é¤J¦b¥t¤@¤À­¶

½Ð±Ð¦U¦ì¡G

§Ú·Q±Nªþ¥ó¤¤ªºÁ`ªí¸ê®Æ­¶¤¤¡A¨Ì·ÓÀ]§O¤Î¼t°Ó§O§ì¥X¸ê®Æ¥t¦s¤JÀ]§O¤Î¼t°Ó¤À­¶¤¤¡A¦]¸ê®Æ¤º®eÄæ¦ì·|ÀH¨C¦¸µ§¼Æ¤£¦P¡A©Ò¥H¤£·|¬O©T©wµ§¼Æ¡A
µ{«×¤Ó®t´Á«Ý°ª¤H«üÂI¡C

À]§O¼t°Ó¦Û°Ê¿ï¾Ü.zip (46.11 KB)

¦^´_ 1# tsuan
  1. Sub ¤ÀÃþ()
  2. Dim A As Range, Ay()
  3. Set Sht = CreateObject("Scripting.Dictionary")
  4. Set dic = CreateObject("Scripting.Dictionary")
  5. With Sheets("Á`ªí")
  6. For Each A In .Range(.[A2], .[A2].End(xlDown))
  7. For i = 5 To 9
  8.    ar = Array(A.Offset(, 1), A.Offset(, 2), A.Offset(, 3), .Cells(A.Row, i).Value)
  9.    If IsEmpty(dic(A & " " & .Cells(1, i))) Then
  10.    ReDim Preserve Ay(1)
  11.    Ay(0) = Array("³f¸¹", "³f«~´y­z", "³æ¦ì", "»ù®æ") '¼ÐÃD¦C
  12.    Ay(1) = ar '¸ê®Æ¦C
  13.       dic(A & " " & .Cells(1, i)) = Ay '¼È¦s©ó¦r¨åª«¥ó¤¤
  14.       Else
  15.       Ay = dic(A & " " & .Cells(1, i)) 'Ū¥X¦r¨å¤º®e
  16.       s = UBound(Ay)
  17.       ReDim Preserve Ay(s + 1)
  18.       Ay(s + 1) = ar '¥[¤J¸ê®Æ¦C
  19.       dic(A & " " & .Cells(1, i)) = Ay '¼È¦s©ó¦r¨åª«¥ó¤¤
  20.     End If
  21. Next
  22. Next
  23. End With
  24. For Each sh In Sheets 'Ū¨ú©Ò¦³¤u§@ªí¦WºÙ
  25.    Sht(sh.Name) = sh.Name
  26. Next
  27. For Each ky In dic.keys
  28. If Not Sht.exists(ky) Then '­Y¤u§@ªí¤£¦s¦b
  29. With Worksheets.Add(after:=Sheets(Sheets.Count)) '·s¼W¤u§@ªí
  30.    .Name = ky
  31. End With
  32. End If
  33. With Sheets(ky) '¼g¤J¤u§@ªí¸ê®Æ
  34.    .[B1] = "À]§O:"
  35.    .[D1] = "¼t°Ó:"
  36.    .[C1] = Split(ky, " ")(0)
  37.    .[E1] = Split(ky, " ")(1)
  38.    .[A3].Resize(UBound(dic(ky)) + 1, 4) = Application.Transpose(Application.Transpose(dic(ky)))
  39. End With
  40. Next
  41. End Sub
½Æ»s¥N½X
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

·PÁª©¥D¤j¤O¨ó§U¡A¦ý¥i¯à¬O§Ú¨S»¡²M·¡¡A
Â^¨ú.PNG
2019-1-16 15:58

§Ú»Ý­nªº¬O§ìAÄæ¦ìªºÀ]§O¤ÎLÄæ¦ìªº¼t°Ó¥æ¶°ªº¸ê®Æ¡A²£¥Í¦p¤Uªíªº¸ê®Æ


§Ú­ì¥»§Æ±æ¬O¯à¨Ì À]§O¤Î¼t°Óªº¤À­¶¤u§@ªí¤W
Â^¨ú.PNG
2019-1-16 16:12

·Q¦bC1 ¤Î E1 ¿é¤J¿z¿ï±ø¥ó«á¡A§ì¨ú¸ê®Æ«á²£¥Í¸ê®Æ©ó¸Ó­¶­±¡A¦ý¦pª©¥Dª½±µ¥Í¦¨·sªº¤u§@ªí¹ê»Ú¤W§ó²Å¦X§Úªº»Ý­n¡C
ÁٽЪ©¥D¦A¨ó§U¡A¤£³Ó·P¿E¡C
Â^¨ú.PNG

TOP

¦^´_ 1# tsuan
½Ð°Ñ¦Ò
  1. Sub test()
  2.     Dim d As Object
  3.     Dim arr
  4.     Dim brr()
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     With Sheets("Á`ªí")
  7.         er = .[A65536].End(3).Row
  8.         arr = .Range("A2:L" & er)
  9.         For c = 5 To 9
  10.             d(.Cells(1, c).Value) = c
  11.         Next c
  12.     End With
  13.     room = Sheets("À]§O¤Î¼t°Ó").[C1].Value
  14.     store = Sheets("À]§O¤Î¼t°Ó").[E1].Value
  15.     n = 0
  16.     For i = 1 To UBound(arr)
  17.         If arr(i, 1) = room And arr(i, 12) = store Then
  18.             n = n + 1
  19.             ReDim Preserve brr(1 To 4, 1 To n)
  20.             For j = 1 To 3
  21.                 brr(j, n) = arr(i, j + 1)
  22.             Next j
  23.             brr(4, n) = arr(i, d(store))
  24.         End If
  25.     Next i
  26.     If n <> 0 Then
  27.         Sheets("À]§O¤Î¼t°Ó").Rows("4:65536").Delete
  28.         Sheets("À]§O¤Î¼t°Ó").[A4].Resize(n, 4) = Application.Transpose(brr)
  29.     Else
  30.         MsgBox "§ä¤£¨ì"
  31.     End If
  32.     Set d = Nothing
  33.     Erase brr
  34.     arr = ""
  35. End Sub
½Æ»s¥N½X

TOP

·PÁÂ Kubi
¥¿¬O¦p§Ú©Ò»Ý­nªº¡A«D±`·P¿E

TOP

¦^´_ 4# Kubi


½Ð°ÝKudi¤j¤j:

§Ú¦bÁ`ªí¸ê®Æ¤W¤è´¡¤J¤@¦C¡A§Y¥X²{°}¦C¯Á¤Þ®Ñ½u¿ù»~°T®§¡AÀµ½Ð±z¦A«ü¾É¤@¤U¡AÁÂÁ¡C

À]§O¼t°Ó¦Û°Ê¿ï¾Ü.zip (53.83 KB)

TOP

¥»©«³Ì«á¥Ñ Kubi ©ó 2019-3-25 20:34 ½s¿è
  1. Sub test()
  2.     Dim d As Object
  3.     Dim arr
  4.     Dim brr()
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     With Sheets("Á`ªí")
  7.         er = .[A65536].End(3).Row
  8.         arr = .Range("A3:L" & er)
  9.         For c = 5 To 9
  10.            d(.Cells(2, c).Value) = c
  11.         Next c
  12.     End With
  13.     room = Sheets("À]§O¤Î¼t°Ó").[C1].Value
  14.     store = Sheets("À]§O¤Î¼t°Ó").[E1].Value
  15.     n = 0
  16.     For i = 1 To UBound(arr)
  17.         If arr(i, 1) = room And arr(i, 12) = store Then
  18.             n = n + 1
  19.             ReDim Preserve brr(1 To 4, 1 To n)
  20.             For j = 1 To 3
  21.                 brr(j, n) = arr(i, j + 1)
  22.             Next j
  23.             brr(4, n) = arr(i, d(store))
  24.         End If
  25.     Next i
  26.     If n <> 0 Then
  27.         Sheets("À]§O¤Î¼t°Ó").Rows("4:65536").Delete
  28.         Sheets("À]§O¤Î¼t°Ó").[A4].Resize(n, 4) = Application.Transpose(brr)
  29.     Else
  30.         MsgBox "§ä¤£¨ì"
  31.     End If
  32.     Set d = Nothing
  33.     Erase brr
  34.     arr = ""
  35. End Sub
½Æ»s¥N½X
¦^´_ 6# tsuan

TOP

·PÁÂ Kubi
¤w¸g¥i¥H¥¿¦¡¨Ï¥Î¤F¡A«D±`·PÁÂ

TOP

ÁÂÁ½׾Â(5001),ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð
µ²ªGªí²M°£Â¸ê®Æ:
20240112_1.jpg
2024-1-12 11:06


¸ê®Æªí:
20240112_2.jpg
2024-1-12 11:06


°õ¦æµ²ªG:
20240112_3.jpg
2024-1-12 11:07


Option Explicit
Sub TEST()
Dim Brr, V, Z, i&, R&, À]$, ¼t$
Sheets("À]§O¤Î¼t°Ó").UsedRange.Offset(3).EntireRow.Delete
À] = [À]§O¤Î¼t°Ó!C1]: ¼t = [À]§O¤Î¼t°Ó!E1]: If À] = "" Or ¼t = "" Then Exit Sub
Brr = Range([Á`ªí!L1], [Á`ªí!A65536].End(xlUp))
For i = 3 To UBound(Brr)
   If Brr(i, 1) <> À] Or Brr(i, 12) <> ¼t Then GoTo i01 Else R = R + 1
   Brr(R, 1) = Brr(i, 2): Brr(R, 2) = Brr(i, 3): Brr(R, 3) = Brr(i, 4)
   Brr(R, 4) = Val(Brr(i, 11)): Brr(R, 5) = Val(Brr(i, 10))
   V = V + Brr(R, 4) * Brr(R, 5)
i01: Next
If R = 0 Then Exit Sub
With [À]§O¤Î¼t°Ó!A4].Resize(R, 5)
   .Value = Brr: .Item(0, 5) = "=Á`ªí!J2"
   For i = 7 To 10: .Borders(i).Weight = 4: Next
   .Item(.Count + 4) = "¦X­p": .Item(.Count + 5) = V
   .Item(.Count + 5).NumberFormatLocal = "G/³q¥Î®æ¦¡""¤¸"""
End With
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 9# Andy2483

Andy ¾Ç¥S, «á½ú¦³¤@¨Ç½s½X¤WªººÃ°Ý·Q¦V§A½Ð±Ð

Sub TEST()
Dim Brr, V, Z, i&, R&, À]$, ¼t$
Sheets("À]§O¤Î¼t°Ó").UsedRange.Offset(3).EntireRow.Delete
À] = [À]§O¤Î¼t°Ó!C1]: ¼t = [À]§O¤Î¼t°Ó!E1]: If À] = "" Or ¼t = "" Then Exit Sub
Brr = Range([Á`ªí!L1], [Á`ªí!A65536].End(xlUp))
For i = 3 To UBound(Brr)
   If Brr(i, 1) <> À] Or Brr(i, 12) <> ¼t Then GoTo i01 Else R = R + 1
   Brr(R, 1) = Brr(i, 2): Brr(R, 2) = Brr(i, 3): Brr(R, 3) = Brr(i, 4)
   Brr(R, 4) = Val(Brr(i, 11)): Brr(R, 5) = Val(Brr(i, 10))
   V = V + Brr(R, 4) * Brr(R, 5)
i01: Next
If R = 0 Then Exit Sub
With [À]§O¤Î¼t°Ó!A4].Resize(R, 5)
   .Value = Brr: .Item(0, 5) = "=Á`ªí!J2"
   For i = 7 To 10: .Borders(i).Weight = 4: Next
  .Item(.Count + 4) = "¦X­p": .Item(.Count + 5) = V
  .Item(.Count + 5).NumberFormatLocal = "G/³q¥Î®æ¦¡""¤¸"""
End With
End Sub

½Ð°Ý¥H¤W¬õ¦âªº¼Ð°O ".item(xxxxx) ¬O¤°»ò·N«ä©O? ¬O«ç¼Ë¥Îªk©O? §Ú¦bºô¤W§ä¹L,¦ý³£ÁÙ¬O¤@ÀYÃú¤ô,©Ò¥H·Q½Ð¾Ç¥S«ü±Ð,ÁÂÁÂ

TOP

        ÀR«ä¦Û¦b : ¥ÌÄ@°µ¡BÅw³ß¨ü¡C
ªð¦^¦Cªí ¤W¤@¥DÃD