[µo°Ý] ½Ð°ÝVBA¥i¥H¿z¿ï«á¡A¹ï¨äµ²ªG¦A¶i¦æ¶i¶¥¿z¿ï¶Ü?

iceandy6150

¤j®a¦n
·Q½Ð°ÝVBA¦³¨S¦³¿ìªk°µ¨ì
¿z¿ï«á¡A¥X¨Óªºµ²ªG¡A¦b°µ¶i¶¥¿z¿ï?

¥H¤U¨Ò¤l
§Ú·Q°µ¨ì¥ý¿z¿ï¥X2021/11/23ªº¶µ¥Ø
¬Ý¬ÝÁ`¦@´X­Ó²Å¦X (¬õ¦â)

µM«á°w¹ï°Ó«~¥h¶i¦æ"¶i¶¥¿z¿ï" (ºñ¦â)  ¤£­«½Æ
³Ì«á¬O§â¦UºØ°Ó«~ªºÁ`¼Æ¶q¥[°_¨Ó (ÂŦâ)

¥\¯à»Ý¨D¡G
§Ú­n°µ¤@­Ó¬d¸ß¥\¯à¡A¨Ï¥ÎªÌ³z¹LInputbox¡Aµ¹§Ú¦~¤ë¤é
§Ú­n±q«Ü¦h«Ü¦h¸ê®Æ¤¤
¥ý¿z¿ï¥X·í¤Ñ¤é´Áªº¸ê®Æ¡AµM«á¤ÀªR·í¤ÑÁ`¦@¦³¦h¤ÖºØÃþªº²£«~¡A¥[Á`¦U²£«~ªº¼Æ¶q
(¦³ÂIÃþ¦ü¼Ï¯Ã¤ÀªR)

¦A½Ð¦U¦ì«ü¾É¡AÁÂÁÂ

¤U¸ü (130.31 KB)

2021-11-29 23:18

´ú¸Õ¿z¿ï¨Ã½Æ»s¯S©w½d³ò.rar (29.08 KB)

¤U¸ü¦¸¼Æ: 11

2021-11-29 23:18

(«ö¶s¤T)

1. Private Sub CommandButton3_Click()
   
2. 
   
3. Dim i
   
4. Dim a
   
5. Dim Sg As Range
   
6. 
   
7. 
   
8. i = Sheets("¤u§@ªí2").Cells(1, 9).Value
   
9. a = Sheets("¤u§@ªí2").Columns(2).End(xlDown).Row
   
10. 
    
11. Dim Rng As Range        '¿z¿ïµ²ªG½d³ò
    
12. 
    
13.     With Sheets("¤u§@ªí2")       '¦b¤u§@ªí2¤¤
    
14.         Set Rng = .UsedRange.Range("A1:F" & a)  '©Ò¦³¸ê®Æ½d³ò¤¤ªºA1~F©³
    
15.         Rng.AutoFilter Field:=1, Criteria1:="2021/11/23"
    
16.         
    
17.         Set fa = [d2:d65536].SpecialCells(xlCellTypeVisible)(1)
    
18.         Set fb = [D65536].End(xlUp)
    
19.         
    
20.         If fa = "" Then
    
21.             MsgBox "¬dµL¸ê®Æ"
    
22.             Sheets("¤u§@ªí2").Range("A:E").AutoFilter
    
23.             Exit Sub
    
24.         End If
    
25.         
    
26.         Set Sg = .Range("A" & fa.Row & ":F" & fb.Row)
    
27.         '¡´·Q°w¹ï­è­è¿z¿ï¥X¨Óªº½d³ò  ¶i¦æ  ¶i¶¥¿z¿ï¤£­«½Æ  ©ñ¨ìK1
    
28.         Sg.AdvancedFilter xlFilterCopy, .Range("D:D"), Sheets("¤u§@ªí2").Range("K1"), True
    
29.    End With
    
30. End Sub

½Æ»s¥N½X

³Ì«á¦A¥Î Application.SumIfs ¥h¥[Á`¦UºØÃþªº°Ó«~¦@¦³¦h¤Ö

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æ«e:

¤U¸ü (106.79 KB)

2023-6-15 10:58

¿é¤J 2021/11/21 «á«ö¶s°õ¦æµ²ªG:

¤U¸ü (112.68 KB)

2023-6-15 10:58

Option Explicit
Sub TEST()
Dim Brr, Z, V1&, V2&, V3, i&, j%, R&, N&, T$
'¡ô«Å§iÅܼÆ
Intersect(ActiveSheet.UsedRange, [U2:Z65536]).ClearContents
If IsDate([S2]) = False Then MsgBox "[S2]»Ý¿é¤J¤é´Á": Exit Sub
'¡ô¦pªG[S2]Àx¦s®æ­È¤£¬O¤é´Á? True´N¸õ¥X´£¥Ü,µ²§ôµ{¦¡°õ¦æ
Set Z = CreateObject("Scripting.Dictionary")
'¡ô¥OZÅܼƬO ¦r¨å
Brr = Range([F1], [A65536].End(xlUp))
'¡ô¥OBrrÅܼƬO ¤Gºû°}¦C,¥HA~FÄæÀx¦s®æ­È±a¤J°}¦C¤¤
For i = 2 To UBound(Brr)
'¡ô³]¶¶°j°é
   T = Brr(i, 1) & "|" & Brr(i, 3) & "|" & Brr(i, 4)
   '¡ô¥OTÅܼƬO ²Ä1.3.4Äæ°j°é°}¦C­Èªº²Õ¦X¦r¦ê,¤¤¶¡¥H"|"¶¡¹j
   If InStr(T, [S2] & "|") = 0 Then GoTo i01
   '¡ô¦pªGT²Õ¦X¦r¦ê¤£²Å¦X±ø¥ó? True´N¸õ¨ì¼Ð¥Üi01¦ì¸mÄ~Äò°õ¦æ
   If Z(Brr(i, 4)) = "" Then V1 = V1 + 1: Z(Brr(i, 4)) = 1
   '¡ô¦pªG°Ó«~¦WºÙ¤£¦bZ¦r¨å¸Ì? True´N¥OV1ÅܼƲ֥[1«á,
   '±N °Ó«~¦WºÙkey¹ïÀ³item§ï¬°1
   V2 = V2 + Brr(i, 5): V3 = V3 + Brr(i, 6)
   '¡ô¥OV2ÅܼƲ֥[ ¼Æ¶q,'¡ô¥OV3ÅܼƲ֥[ ®ø¶Oª÷ÃB
   N = Z(T)
   '¡ô¥ONÅܼƬO ¥HTÅܼƬdZ¦r¨å¦^¶Çitem­È
   If N = 0 Then
   '¡ô¦pªGNÅܼƬO 0
      R = R + 1: For j = 1 To 6: Brr(R, j) = Brr(i, j): Next
      '¡ô¥ORÅܼƲ֥[1,³]¶¶°j°é±N°j°é¦C°}¦C­ÈÁèì«ü©wªº RÅܼƦC
      Z(T) = R: GoTo i01
     '¡ô¥OTÅܼÆkey¹ïÀ³item§ï¬°RÅܼÆ,¥O¸õ¨ì¼Ð¥Üi01¦ì¸mÄ~Äò°õ¦æ
   End If
   Brr(N, 5) = Brr(N, 5) + Brr(i, 5): Brr(N, 6) = Brr(N, 6) + Brr(i, 6)
   '¡ô¥O²Ä¤G¦¸¥H¤W¥X²{ªºTÅܼÆ,¨ä¼Æ¶q»P®ø¶Oª÷ÃB²Ö¥[
i01: Next
If R > 0 Then R = R + 1 Else: MsgBox "µL²Å¦X±ø¥ó¸ê®Æ": Exit Sub
For j = 1 To 3: Brr(R, j) = "": Next
Brr(R, 4) = V1: Brr(R, 5) = V2: Brr(R, 6) = V3
'¡ô¥O¥[Á`­È©ñ¦b°}¦C¸Ì
[U2].Resize(R, 6) = Brr
'¡ô¥O±q[U2]ÂX®i½d³òÀx¦s®æ­È¥HBrr°}¦C­È¼g¤J,¶W¹L½d³òªº°}¦C­È©¿²¤
Set Z = Nothing: Erase Brr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub

iceandy6150

¦^´_ 4# samwang


«D±`·PÁÂsamwang¤j¤j±Ð¾Ç
ÁÂÁ§A

samwang

¦^´_  samwang


samwang¤j¤j¡A¥i¥H¨Ï¥Î
·PÁ§A

¦pªG§A¤è«Kªº¸Ü
¥i¥H¤U¤@¨Çµù¸Ñ¶Ü?  
¹ï©ó¦r¨å ÁÙ ...
iceandy6150 µoªí©ó 2021-11-30 15:37

Sub test()
Dim Arr, Brr(), xD, T1, T4$, ND As Date, i&, j%, n%
Set xD = CreateObject("Scripting.Dictionary")
ND = InputBox("½Ð¿é¤J¤é´Á¡G", "¤é´Á", "2021/1/1") '»Ý¨D¤é´Á
Arr = Range([e1], [a65536].End(3))  '¸ê®Æ¸Ë¤JArr¼Æ²Õ
ReDim Brr(1 To UBound(Arr), 1 To 5) '²Å¦X»Ý¨DªºBrr¼Æ²Õ
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1): T4 = Arr(i, 4)
    If ND = T1 And xD(T4) = "" Then '¦³²Å¦X¤é´Á¥B°Ó«~¦WºÙ¤£­«½Æ
        n = n + 1: xD(T4) = n       '²Î­p°Ó«~¤£­«½Æ¼Æ¶q
        For j = 1 To 5: Brr(n, j) = Arr(i, j): Next  '²Å¦X¸ê®Æ¸Ë¨ìBrr¼Æ²Õ
        xD(ND & "/1") = xD(ND & "/1") + Arr(i, 5)    '²Î­p¼Æ¶q¸Ë¦r¨å
    End If
Next
[u1].CurrentRegion = "" '²M°£
If n > 0 Then
    Range("a1:f1").Copy [u1]            'copy©ïÀY
    Range("u2").Resize(n, 5) = Brr      '¶×¥XBrr
    Range("x" & n + 2) = n              '¶×¥X²Î­p°Ó«~¤£­«½Æ¼Æ¶q
    Range("y" & n + 2) = xD(ND & "/1")  '¶×¥X²Î­p¼Æ¶q
Else
    MsgBox "µL¸ê®Æ"
End If
End Sub

iceandy6150

¦^´_ 2# samwang


samwang¤j¤j¡A¥i¥H¨Ï¥Î
·PÁ§A

¦pªG§A¤è«Kªº¸Ü
¥i¥H¤U¤@¨Çµù¸Ñ¶Ü?  
¹ï©ó¦r¨å ÁÙ¦³°}¦Cªº¥Îªk
§Ú¤ñ¸û·Q¤£³z
·PÁ§A³á

samwang

¦^´_ 1# iceandy6150

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
Sub test()
Dim Arr, Brr(), xD, T1, T4$, ND As Date, i&, j%,n%
Set xD = CreateObject("Scripting.Dictionary")
ND = InputBox("½Ð¿é¤J¤é´Á¡G", "¤é´Á", "2021/1/1")
Arr = Range([e1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 5)
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1): T4 = Arr(i, 4)
    If ND = T1 And xD(T4) = "" Then
        n = n + 1: xD(T4) = n
        For j = 1 To 5: Brr(n, j) = Arr(i, j): Next
        xD(ND & "/1") = xD(ND & "/1") + Arr(i, 5)
    End If
Next
[u1].CurrentRegion = ""
If n > 0 Then
    Range("a1:f1").Copy [u1]
    Range("u2").Resize(n, 5) = Brr
    Range("x" & n + 2) = n
    Range("y" & n + 2) = xD(ND & "/1")
Else
    MsgBox "µL¸ê®Æ"
End If
End Sub