如何在Excel中将一个大表拆分为多个小表？

网友投稿 382 2024-02-11

如何在Excel中将一个大表拆分为多个小表？

现在，如果您有一个包含多列和成百上千行数据的大型工作表，则希望根据列值或行数将该大型表拆分为多个小型表，以获得以下结果。您如何在Excel中处理此任务？

主表 按列值将表拆分为多个表 按行数将表拆分为多个表

使用VBA代码根据列值将大表拆分为多个表

使用VBA代码根据特定的行数将一个大表拆分为多个表

基于列值或行数将大型表拆分为多个表，具有惊人的功能

使用VBA代码根据列值将大表拆分为多个表

若要根据特定的列值将此大表拆分为多个表，请使用以下VBA代码。请这样做：

1。按住 ALT + F11 键打开 Microsoft Visual Basic应用程序 窗口。

2。点击插页 > 模块，然后将以下代码粘贴到模块窗口。

VBA代码：按关键字列将一个大表拆分为多个表：

Sub Splitdatabycol() by Extendoffice Dim lr As Long Dim ws As Worksheet Dim vcol, i As Integer Dim icol As Long Dim myarr As Variant Dim title As String Dim titlerow As Integer Dim xTRg As Range Dim xVRg As Range Dim xWSTRg As Worksheet On Error Resume Next Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8) If TypeName(xTRg) = "Nothing" Then Exit Sub Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8) If TypeName(xVRg) = "Nothing" Then Exit Sub vcol = xVRg.Column Set ws = xTRg.Worksheet lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row title = xTRg.AddressLocal titlerow = xTRg.Cells(1).Row icol = ws.Columns.Count ws.Cells(1, icol) = "Unique" Application.DisplayAlerts = False If Not Evaluate("=ISREF(xTRgWs_Sheet!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet" Else Sheets("xTRgWs_Sheet").Delete Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet" End If Set xWSTRg = Sheets("xTRgWs_Sheet") xTRg.Copy xWSTRg.Paste Destination:=xWSTRg.Range("A1") ws.Activate For i = (titlerow + xTRg.Rows.Count) To lr On Error Resume Next If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) End If Next myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) ws.Columns(icol).Clear For i = 2 To UBound(myarr) ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" If Not Evaluate("=ISREF(" & myarr(i) & "!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" Else Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) End If xWSTRg.Range(title).Copy Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1") ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count)) Sheets(myarr(i) & "").Columns.AutoFit Next xWSTRg.Delete ws.AutoFilterMode = False ws.Activate Application.DisplayAlerts = True End Sub

3。粘贴代码后，按 F5 键运行此代码，并弹出提示框，请从数据中选择标题行，请参见屏幕截图：

4。然后，点击 OK，然后会弹出另一个对话框，请选择要用于拆分表的列数据，请参见屏幕截图：

5。点击 OK，此大表已通过位于主表之后的列值拆分为多个工作表。并且新工作表使用列值命名。看截图：

使用VBA代码根据特定的行数将一个大表拆分为多个表

如果需要根据行数将表拆分为多个表，则以下VBA代码可以为您提供帮助。

1。按住 ALT + F11 键打开 Microsoft Visual Basic应用程序 窗口。

2。点击插页 > 模块，然后将以下代码粘贴到模块窗口。

VBA代码：按行数将一个大表拆分为多个表：

Sub Splitdatabyrows() Updated by Extendoffice Dim WorkRng As Range Dim xRow As Range Dim SplitRow As Integer Dim xWs As Worksheet Dim xTRg As Range Dim xNTRg As Range Dim xIER On Error Resume Next xTitleId = "KutoolsforExcel" Set WorkRng = Application.Selection Set xTRg = Application.InputBox("Please select the header row:", xTitleId, "", Type:=8) If TypeName(xTRg) = "Nothing" Then Exit Sub Set WorkRng = Application.InputBox("Please select the data range(exclude the header row):", xTitleId, WorkRng.Address, Type:=8) If TypeName(WorkRng) = "Nothing" Then Exit Sub SplitRow = Application.InputBox("Split Row Num", xTitleId, Type:=1) If SplitRow = 0 Then Exit Sub Set xWs = WorkRng.Parent Set xRow = WorkRng.Rows(1) xIER = WorkRng.Rows.Count xIER = WorkRng.Row + xIER - 1 Application.ScreenUpdating = False For i = 1 To WorkRng.Rows.Count Step SplitRow resizeCount = SplitRow If (xIER - xRow.Row + 1) < SplitRow Then resizeCount = (xIER - xRow.Row + 1) End If xRow.Resize(resizeCount).Copy Set xWs = Application.Worksheets.Add(after:=Application.Worksheets(Application.Worksheets.Count)) If xIER > (xRow.Row + SplitRow - 1) Then xWs.Name = xRow.Row & " - " & (xRow.Row + SplitRow - 1) ElseIf xIER = xRow.Row Then xWs.Name = xRow.Row Else xWs.Name = xRow.Row & " - " & xIER End If Application.ActiveSheet.Range("A1").PasteSpecial Set xNTRg = Application.ActiveSheet.Range("A1") xTRg.Copy xNTRg.Insert Set xRow = xRow.Offset(SplitRow) Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub