­ã´£³¡ªL

Sub TEST()
Dim j&, Jm&, Arr, Brr, xS As Worksheet, xD, N&
Sheets("Á`©M²Î­pªí").UsedRange.Offset(1, 0).ClearContents
¡@
ReDim Brr(1 To 6000, 1 To 8) '¡Ä°}¦C¹w³]®e¯Ç 6000 ¦C¡A¥i¦Û¦æ½Õ¾ã
Set xD = CreateObject("Scripting.Dictionary")
¡@
For Each xS In Sheets(Array("¤â¼g¤é³øªí", "¹q¸£¤é³øªí", "¶i³fªí"))
¡@¡@Arr = xS.UsedRange.Offset(1, 0).Value
¡@¡@For j = 1 To UBound(Arr)
¡@¡@¡@¡@Jm = xD(Arr(j, 1)):   If Arr(j, 1) = "" Then GoTo 99
¡@¡@¡@¡@If Jm = 0 Then N = N + 1: xD(Arr(j, 1)) = N: Jm = N
¡@¡@¡@¡@Brr(Jm, 1) = Arr(j, 1):    Brr(Jm, 2) = Arr(j, 2)
¡@¡@¡@¡@If xS.Name = "¶i³fªí" Then
¡@¡@¡@¡@¡@¡@Brr(Jm, 5) = Brr(Jm, 5) + Arr(j, 4) + Arr(j, 5) '¡ÄÁ`¶i³f
¡@¡@¡@¡@¡@¡@If InStr(" " & Brr(Jm, 6) & " ", " " & Arr(j, 6) & " ") = 0 Then  '¡Ä±Æ°£­«ÂÐ
¡@¡@¡@¡@¡@¡@¡@¡@Brr(Jm, 6) = Trim(Brr(Jm, 6) & " " & Arr(j, 6)) '¡Ä¬ö©À«~
¡@¡@¡@¡@¡@¡@End If
¡@¡@¡@¡@¡@¡@Brr(Jm, 8) = Trim(Brr(Jm, 8) & " " & Arr(j, 7)) '¡Ä³Æµù
¡@¡@¡@¡@Else
¡@¡@¡@¡@¡@¡@Brr(Jm, 3) = Brr(Jm, 3) + Arr(j, 4) '¡ÄÁ`±i¼Æ
¡@¡@¡@¡@¡@¡@Brr(Jm, 4) = Brr(Jm, 4) + Arr(j, 5) '¡ÄÁ`ªÑ¼Æ
¡@¡@¡@¡@¡@¡@Brr(Jm, 8) = Trim(Brr(Jm, 8) & " " & Arr(j, 6)) '¡Ä³Æµù
¡@¡@¡@¡@End If
¡@¡@¡@¡@Brr(Jm, 7) = Brr(Jm, 5) - Brr(Jm, 3) '¡ÄÁ`¶i³f-Á`±i¼Æ
99: Next
Next
¡@
If N = 0 Then Exit Sub
With [Á`©M²Î­pªí!A2:H2].Resize(N)
¡@¡@¡@.Value = Brr
¡@¡@¡@.Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
End With
End Sub

µ{¦¡½X¬Ý°_¨Ó«Ü¦h, ¨ä¹ê³£¥u¬O[°Ñ·Ó¦ì¸m]¦Ó¤w, ½Ð¦Û¦æ¥hºCºC·N·|, ¤£¦h°µ»¡©ú¤F~~