VBA实战技巧精粹之按某列相同数据分入同一个sheet

效果

代码

Function WorkSheetExists(oWB As Workbook, ByVal sWkName As String) As Boolean
    '判断指定名称的工作表是否存在
    'oWB为具体的工作簿,sWkName为工作表的名称,结果返回True表示存在
    On Error Resume Next
    Dim oWK As Worksheet
    Set oWK = oWB.Worksheets(sWkName)
    '如果出错表示不存在指定名称的工作表
    If Err.Number <> 0 Then
        WorkSheetExists = False
    Else
        WorkSheetExists = True
    End If
    Err.Clear
End Function

'按照第几列批量创建sheet
Sub shi()
Dim i, j, row_number, g As Integer
Dim k As Boolean
Dim l As Integer
Dim sht As Worksheet
'sheet名称规定少于31个字符，所以定义数组存储sheet名称，做超链接时使用
dim arr(1000) as string 
dim arrindex as Integer 
l = InputBox("请输入你要按哪列分")
arrindex=1
arr(0)="Sheet1"
row_number = Sheet1.Range("a65535").End(xlUp).Row
'删除无意义的表
If Sheets.Count > 1 Then
    Excel.Application.DisplayAlerts = False
    'For g = 2 To Sheets.Count  
        'Sheets(g).Delete
    'Next
    For Each sht In Sheets
        If sht.Name <> "Sheet1" Then
            sht.Delete
        End If
    Next
    Excel.Application.DisplayAlerts = True
'从数据列开始循环
End If
For i = 2 To row_number
    k = False  
    For j = 1 To Sheets.Count
        If Left(Sheet1.Cells(i, l).Value, 31) = Sheets(j).Name Then
            k = True
            Exit For
        End If
    Next       
    If k = False Then
        '创建表格,建立表格时，将没有截取前的数据存入数组
		arr(arrindex)=Sheet1.Cells(i, l).Value
		arrindex=arrindex+1
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Left(Sheet1.Cells(i, l).Value, 31)		
    End If
Next
arrindex=1
For j = 2 To Sheets.Count
    Sheet1.Range("a1:o" & row_number).AutoFilter Field:=l, Criteria1:=arr(arrindex)
    Sheet1.Range("a1:o" & row_number).Copy Sheets(j).Range("a2")
    arrindex=arrindex+1
Next
Sheet1.Range("a1:o" & row_number).AutoFilter
    Excel.Application.DisplayAlerts = False
    On Error Resume Next
    Dim oWK As Worksheet
    Dim oWB As Workbook
    Dim oSp As Shape
    Set oWB = Excel.ActiveWorkbook
   If WorkSheetExists(oWB, "导航目录") = False Then
        Set oWK = oWB.Worksheets.Add(Excel.Worksheets(1))
        oWK.Name = "导航目录"
        oWK.Range("a1") = "目录"
   Else
        Set oWK = oWB.Worksheets("导航目录")
        oWK.Delete
        Set oWK = oWB.Worksheets.Add(Excel.Worksheets(1))
        oWK.Name = "导航目录"
        oWK.Range("a1") = "目录"
   End If
   Dim oWK1 As Worksheet
   i = 2
 arrindex=0  
   For Each oWK1 In oWB.Worksheets
			Dim oRng As Range
			If oWK1.Name <> oWK.Name Then
				'oWK1.Shapes("超链接").Delete
				Set oRng = oWK.Range("a" & i)
				sAddress = oWK1.Range("a1").Address(, , , True)
				oWK.Hyperlinks.Add oRng, "", sAddress, ,  arr(arrindex)'oWK1.Name
				if oWK1.Name<>"Sheet1" then
				oWK1.Hyperlinks.Add oWK1.Range("a1"), "", oWK.Range("a1").Address(, , , True), , ""						
			   oWK1.Range("a1") = "返回"
			   end if	
				i = i + 1
				arrindex=arrindex+1
			End If
   Next
   Excel.Application.DisplayAlerts = True
   MsgBox "处理完毕"
   Sheets(2).Select
End Sub