Option Explicit
Public Sub GPE()
Dim Arr, dArr, I As Long, J As Long, K As Long, X As Long, TCong(1 To 1, 1 To 19)
Dim ShMau As Worksheet, ShDs As Worksheet, Wb As Workbook
Dim Dic As Object, Tem As String
Application.ScreenUpdating = False
Set Wb = ActiveWorkbook
Set ShMau = Wb.Sheets("Form")
Set ShDs = Wb.Sheets("DaTa")
Arr = ShDs.Range("A13", ShDs.Range("A65000").End(4)).Resize(, 28).Value2
ReDim dArr(1 To UBound(Arr), 1 To 26)
Set Dic = CreateObject("Scripting.Dictionary")
ShMau.Copy
For I = 1 To UBound(Arr)
If Arr(I, 1) <> Empty Then
Tem = Arr(I, 28)
If Not Dic.exists(Tem) Then
Dic.Add Tem, ""
ActiveSheet.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Left(Tem, 31)
K = 0
For X = 1 To UBound(Arr)
If Arr(X, 1) <> Empty Then
If Arr(X, 28) = Tem Then
K = K + 1
dArr(K, 1) = Arr(X, 1)
dArr(K, 2) = K
For J = 3 To 26
dArr(K, J) = Arr(X, J)
Next J
For J = 1 To 19
TCong(1, J) = TCong(1, J) + Arr(X, J + 6)
Next J
End If
End If
Next X
If K > 2 Then .Rows("13:" & K + 10).Insert Shift:=xlDown
.Range("A12").Resize(K, 26).Value = dArr
.Range("G11").Resize(, 19).Value = TCong
.Range("A3").Value = "C" & ChrW(7910) & "A" & Tem
End With
End If
Sheets(1).Activate
End If
Next I
Sheets(1).Delete
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub
