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
Sub TonghopArr()
Dim sArray, subArr(), Arr(), i As Long, n 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")
With Sheets("Data")
sArray = .Range("A5:E1000").Value
Title = .Range("A4:E4").Value
End With
ReDim ArrBP(1 To UBound(sArray, 1), 1 To 2)
For i = 1 To UBound(sArray, 1)
If Len(CStr(sArray(i, 2))) Then
Tmp = CStr(sArray(i, 2))
If Not Dic.Exists(Tmp) Then
n = n + 1
Dic.Add Tmp, n
ArrBP(n, 1) = Tmp
End If
nR = Dic.Item(Tmp)
If Len(ArrBP(nR, 1)) Then
ArrBP(nR, 2) = ArrBP(nR, 2) & vbBack & i
Else
ArrBP(nR, 2) = i
End If
End If
Next
For i = 1 To n
nR = 0
Tmp = CStr(ArrBP(i, 2))
aSplit = Split(Tmp, vbBack)
ReDim subArr(1 To UBound(aSplit), 1 To UBound(sArray, 2))
For j = 1 To UBound(aSplit)
nR = nR + 1
For k = 1 To UBound(sArray, 2)
subArr(nR, k) = sArray(aSplit(j), k)
Next k
Next j
WshName = CStr(ArrBP(i, 1))
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.ClearContent
.Name = WshName
.Range("A1").Resize(, UBound(sArray, 2)).Value = Title
.Range("A2").Resize(UBound(aSplit), UBound(sArray, 2)) = subArr
End With
Next i
MsgBox Timer - T
End Sub
