Sub TonghopArr()
Dim DL, KQ(), Arr(), i As Long, Title, nR&, k&, n&
Dim tmpR As Long, p As Long, lC As Long, keyArr, WshName As String
Dim Dic As Object, Tmp As String, ArrBP()
Dim T
T = Timer
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With Sheets("Data")
DL = .Range("A5:E60000").Value
Title = .Range("A4:E4").Value
End With
For i = 1 To UBound(DL, 1)
If Len(CStr(DL(i, 2))) Then
Tmp = CStr(DL(i, 2))
If Not Dic.Exists(Tmp) Then
n = n + 1
Dic.Add Tmp, n
ReDim Preserve ArrBP(1 To n)
End If
nR = Dic.Item(Tmp)
If Len(ArrBP(nR)) Then
ArrBP(nR) = ArrBP(nR) & vbBack & i
Else
ArrBP(nR) = i
End If
End If
Next
For i = 1 To UBound(ArrBP)
nR = 0
Tmp = CStr(ArrBP(i))
aSplit = Split(Tmp, vbBack)
ReDim KQ(1 To UBound(aSplit) + 1, 1 To UBound(DL, 2))
For j = 0 To UBound(aSplit)
nR = nR + 1
For k = 1 To UBound(DL, 2)
KQ(nR, k) = DL(aSplit(j), k)
Next k
Next j
WshName = CStr(KQ(1, 2))
If isValidWshName(WshName) Then
If Not SheetExist(WshName) Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WshName
End If
End If
With Sheets(WshName)
.UsedRange.ClearContents
.Range("A1").Resize(, UBound(DL, 2)).Value = Title
.Range("A2").Resize(UBound(aSplit) + 1, UBound(DL, 2)) = KQ
End With
Next i
Application.ScreenUpdating = True
MsgBox Timer - T
End Sub
Function SheetExist(ByVal WshName As String) As Boolean
On Error Resume Next
SheetExist = Not ThisWorkbook.Sheets(WshName) Is Nothing
End Function
Function isValidWshName(ByVal WshName As String) As Boolean
Dim i As Long, InvalidName As String
InvalidName = ":\/?*[]"
If Len(WshName) > 31 Or Len(WshName) = 0 Then Exit Function
For i = 1 To Len(InvalidName)
If InStr(WshName, Mid(InvalidName, i, 1)) Then Exit Function
Next
isValidWshName = True
End Function
