效果

代碼

Function WorkSheetExists(oWB As Workbook, ByVal sWkName As String) As Boolean'判斷指定名稱的工作表是否存在'oWB為具體的工作簿,sWkName為工作表的名稱,結果返回True表示存在On Error Resume NextDim oWK As WorksheetSet oWK = oWB.Worksheets(sWkName)'如果出錯表示不存在指定名稱的工作表If Err.Number <> 0 ThenWorkSheetExists = FalseElseWorkSheetExists = TrueEnd IfErr.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 ThenExcel.Application.DisplayAlerts = False'For g = 2 To Sheets.Count 'Sheets(g).Delete'NextFor Each sht In SheetsIf sht.Name <> "Sheet1" Thensht.DeleteEnd IfNextExcel.Application.DisplayAlerts = True '從數據列開始循環 End If For i = 2 To row_numberk = False For j = 1 To Sheets.CountIf Left(Sheet1.Cells(i, l).Value, 31) = Sheets(j).Name Thenk = TrueExit ForEnd IfNext If k = False Then'創建表格,建立表格時，將沒有截取前的數據存入數組arr(arrindex)=Sheet1.Cells(i, l).Valuearrindex=arrindex+1Sheets.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.CountSheet1.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).AutoFilterExcel.Application.DisplayAlerts = FalseOn Error Resume NextDim oWK As WorksheetDim oWB As WorkbookDim oSp As ShapeSet oWB = Excel.ActiveWorkbookIf WorkSheetExists(oWB, "導航目錄") = False ThenSet oWK = oWB.Worksheets.Add(Excel.Worksheets(1))oWK.Name = "導航目錄"oWK.Range("a1") = "目錄"ElseSet oWK = oWB.Worksheets("導航目錄")oWK.DeleteSet oWK = oWB.Worksheets.Add(Excel.Worksheets(1))oWK.Name = "導航目錄"oWK.Range("a1") = "目錄"End IfDim oWK1 As Worksheeti = 2arrindex=0 For Each oWK1 In oWB.WorksheetsDim oRng As RangeIf oWK1.Name <> oWK.Name Then'oWK1.Shapes("超鏈接").DeleteSet oRng = oWK.Range("a" & i)sAddress = oWK1.Range("a1").Address(, , , True)oWK.Hyperlinks.Add oRng, "", sAddress, , arr(arrindex)'oWK1.Nameif oWK1.Name<>"Sheet1" thenoWK1.Hyperlinks.Add oWK1.Range("a1"), "", oWK.Range("a1").Address(, , , True), , "" oWK1.Range("a1") = "返回"end if i = i + 1arrindex=arrindex+1End IfNextExcel.Application.DisplayAlerts = TrueMsgBox "處理完畢"Sheets(2).Select End Sub

總結

以上是生活随笔為你收集整理的VBA实战技巧精粹之按某列相同数据分入同一个sheet的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。