| ©«¤l4901 ¥DÃD44 ºëµØ24 ¿n¤À4916 ÂI¦W267  §@·~¨t²ÎWindows 7 ³nÅ骩¥»Office 20xx ¾\ŪÅv150 ©Ê§O¨k ¨Ó¦Û¥x¥_ µù¥U®É¶¡2010-4-30 ³Ì«áµn¿ý2025-10-31 
                
 | 
                
| ¦^´_ 22# white5168 §â¾ãÅé¬yµ{·§©Àµù¸Ñ«á¡A¬Ý¬Ý»P§Aªº·Qªk¸¨®t¦bþ?
 ½Æ»s¥N½XSub Get_Data()
Dim Ar(), Ay(), x, Mystr$, A
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
ChDir ThisWorkbook.Path
fs = Application.GetOpenFilename("³rÂI¤À¹j (CSV) (*.csv), *.csv") '¶}±Ò¸ê®ÆÀÉ®×¹ï¸Ü¤è¶ô¿ï¾ÜCSVÀÉ®×
Open fs For Input As #1 'Ū¨úCSVÀÉ®×
Do Until EOF(1)
   Line Input #1, Mystr 'Ū¨ú¤@¦æ¸ê®Æ¼g¤JÅܼÆ
   A = Split(Mystr, ",") '±N¸ê®Æ¤Á³Î¦s¤J°}¦C
   If Val(A(0)) > 0 And Val(A(0)) <= [B1] Then '§PÂ_¬O§_¦bµ²ºâ¤é´Á¤§«eªº¸ê®Æ
   If IsEmpty(d(A(1))) Then '¥H²£«~½s¸¹¬°¯Á¤ÞY¤£¦s¦b
       For i = 1 To Val(A(3)) '¥H¶R¤J¼Æ¶q°µ°j°é¡B°O¾Ð¦í¨C¤@Óªº³æ»ù
          ReDim Preserve Ar(i)
          Ar(i - 1) = Val(A(2))
       Next
       If Val(A(3)) > 0 Then d(A(1)) = Ar '¦pªG¦³¼Æ¶q´N±N°}¦C¦s¨ì¦r¨å¤¤
       Else '¤]´N¬O¦³²Ä¤Gµ§¥H¤W¶R¤J®É°õ¦æ
       Ar = d(A(1)) '¥ý¨ú¥X¸Ó½s¸¹¤w¸gÁʶRªº¸ê®Æ¦s¤J°}¦C
       s = UBound(Ar)
         For i = 1 To Val(A(3)) '±N¨Cµ§¸ê®Æ³æ»ù¥[¤J¦¹°}¦C
           ReDim Preserve Ar(s + i)
           Ar(s + i - 1) = Val(A(2))
         Next
       s = UBound(Ar)
         d(A(1)) = Ar '±N°}¦C¦^¦s¨ì¦r¨åª«¥ó
    End If
    If Val(A(4)) > 0 Then '½æ¥X¸ê°T³B²z¡A»P¶R¤JÆ[©À¬Û¦P
       If IsEmpty(d1(A(1))) Then
       For i = 1 To Val(A(4))
          ReDim Preserve Ar(i)
          Ar(i - 1) = Val(A(2))
       Next
       If Val(A(4)) > 0 Then d1(A(1)) = Ar
       Else
       Ar = d1(A(1))
       s = UBound(Ar)
         For i = 1 To Val(A(4))
           ReDim Preserve Ar(s + i)
           Ar(s + i - 1) = Val(A(2))
         Next
         d1(A(1)) = Ar
    End If
    End If
    End If
   Erase Ay: Erase Ar '³B²z¤U¤@µ§¸ê®Æ«e¥ý§âì¨Óªº¶R½æ°O¾Ð®ø°£
Loop
Close #1 'Ãö³¬CSVÀÉ®×
For Each ky In d1.keys
   If IsArray(d1(ky)) Then Ar = d1(ky): x = UBound(Ar) Else x = 0 '¥X³f¸ê®ÆY¬O°}¦C´N¨ú¥X°}¦C¥i±oª¾¨ì©³¦³´Xµ§¥X³f¸ê°T
   If IsArray(d(ky)) Then Ay = d(ky): y = UBound(Ay) Else y = 0 '¶i³f¸ê®ÆY¬O°}¦C´N¨ú¥X°}¦C¥i±oª¾¨ì©³¦³´Xµ§¶i³f¸ê°T
   '¥H¤U´N¤£¦Pª¬ªppºâ¦UÄæ¦ìÀ³¦³ªºÈ¼g¤J°}¦C
   If x = 0 And y > 0 Then '¥u¶i¤£¥X
        bp = Application.Average(Ay) '¶i³f¥§¡»ù
      d2(ky) = Array(ky, y, 0, 0, Abs(y - x), y - x, Round(bp, 2), 0)
      bp = 0
      ElseIf y = 0 And x > 0 Then '¥u¥X¤£¶i
      sp = Application.Average(Ar) '¥X³f¥§¡»ù
      d2(ky) = Array(ky, y, x, 0, 0, y - x, 0, Round(sp, 2))
      sp = 0
      ElseIf x > 0 And y > 0 Then
         If x > y Then '¥X¤j©ó¶i
         w = 0: w1 = y - x
         For i = 0 To y - 1
         pr = pr + Ar(i) - Ay(i) 'pºâ¥X³f»P¶i³fªº»ù®t²Öp¡B³o¬O¯u¥¿Àò§QÈ¥i¯à»P´£°ÝªÌªºÆ[©À®t²§
         Next
         For j = i To x - 1 '¤£°÷¦©pºâ
         nr = nr + Ar(i)
         Next
         nr = nr / (x - y) '¤£¨¬¶q
         ElseIf x < y Then '¶i¤j©ó¥X
         w1 = 0: w = y - x
         For i = 0 To x - 1
         pr = pr + Ar(i) - Ay(i) 'pºâ¥X³f»P¶i³fªº»ù®t²Öp¡B³o¬O¯u¥¿Àò§QÈ¥i¯à»P´£°ÝªÌªºÆ[©À®t²§
         Next
         For j = i To y - 1 '³Ñ¾l¶qpºâ
         sr = sr + Ay(i)
         Next
         sr = sr / Abs(x - y) '¤£¨¬¶q
         End If
         d2(ky) = Array(ky, y, x, pr, w, w1, Round(sr, 2), Round(nr, 2)) '¼g¤J°}¦C
         pr = 0: nr = 0: sr = 0
   End If
   Erase Ay: Erase Ar
Next
[A4:H65536] = ""
[A4].Resize(d2.Count, 8) = Application.Transpose(Application.Transpose(d2.items))
End Sub
 | 
 |