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

tsuan

½Ð±Ð¦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

Hsieh

¦^´_ 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

tsuan

·PÁª©¥D¤j¤O¨ó§U¡A¦ý¥i¯à¬O§Ú¨S»¡²M·¡¡A

¤U¸ü (22.96 KB)

2019-1-16 15:58

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


§Ú­ì¥»§Æ±æ¬O¯à¨Ì À]§O¤Î¼t°Óªº¤À­¶¤u§@ªí¤W

¤U¸ü (19.37 KB)

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

Kubi

¦^´_ 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

tsuan

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

tsuan

¦^´_ 4# Kubi


½Ð°ÝKudi¤j¤j:

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

Kubi

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

tsuan

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

Andy2483

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

¤U¸ü (54.83 KB)

2024-1-12 11:06

¸ê®Æªí:

¤U¸ü (299.42 KB)

2024-1-12 11:06

°õ¦æµ²ªG:

¤U¸ü (142.3 KB)

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

mdr0465

¦^´_ 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«ü±Ð,ÁÂÁÂ