跳到主要內容

如何在Excel中將一個大表拆分為多個小表?

作者:小陽 最後修改時間:2022-07-14

現在,如果您有一個包含多列和成百上千行數據的大型工作表,則希望根據列值或行數將該大型表拆分為多個小型表,以獲得以下結果。 您如何在Excel中處理此任務?

主表   按列值將表拆分為多個表 按行數將表拆分為多個表

使用VBA代碼根據列值將大表拆分為多個表

使用VBA代碼根據特定的行數將一個大表拆分為多個表

基於列值或行數將大型表拆分為多個表,具有驚人的功能


使用VBA代碼根據列值將大表拆分為多個表

若要根據特定的列值將此大表拆分為多個表,請使用以下VBA代碼。 請這樣做:

1。 按住 ALT + F11 鍵打開 Microsoft Visual Basic for Applications 窗口。

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 for Applications 窗口。

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

3。 然後按 F5 鍵,在彈出的對話框中,選擇標題行,請參見屏幕截圖:

4。 然後,點擊 OK,然後在第二個提示框中,選擇要按行計數拆分的數據范圍,請參見屏幕截圖:

5。 然後,繼續點擊 OK 按鈕,在第三個提示框中,輸入要分割的行數,請參見屏幕截圖:

6。 然後,點擊 OK 按鈕,主表已根據行數分為多個工作表,如下圖所示:


基於列值或行數將大型表拆分為多個表,具有驚人的功能

可能上述代碼對大多數用戶來說很困難,在這裡,我將介紹一個很棒的功能-拆分數據 of Excel的Kutools。 使用此實用程序,您可以快速,輕鬆地按鍵列或行數將一個大表拆分為多個表。

提示:要應用此 拆分數據 功能,首先,您應該下載 Excel的Kutools,然後快速輕鬆地應用該功能。

安裝後 Excel的Kutools,請這樣做:

1。 選擇要拆分的數據范圍,然後單擊 Kutools 加 > 拆分數據,請參見屏幕截圖:

2。 在 將數據拆分為多個工作表 對話框中,指定所需的設置:

(1.)選擇 特定欄 or 固定行 來自 分割依據 您需要的部分;

(2.)從 規則 下拉列表中,您可以添加 字首 or 後綴 以及工作表名稱。

3。 然後,點擊 Ok 按鈕,現在,大表已在新工作簿中拆分為多個小表。 查看屏幕截圖:

按列值將表拆分為多個表 按行數將表拆分為多個表

點擊下載Kutools for Excel並立即免費試用!


更多相關文章:

  • 拆分工作簿以在Excel中分離Excel文件
  • 您可能需要將一個大型工作簿拆分為單獨的Excel文件,然後將工作簿的每個工作表另存為單獨的Excel文件。 例如,您可以將工作簿拆分為多個單獨的Excel文件,然後將每個文件交付給不同的人來處理。 這樣,您可以讓某些人處理特定數據,並確保您的數據安全。 本文將介紹根據每個工作表將大型工作簿拆分為單獨的Excel文件的方法。
  • 在Excel中將全名拆分為名字和姓氏
  • 假設您有一個名字列表,如下面的單個列中顯示的第一個屏幕截圖所示,則需要將全名拆分為名字列,中間名列和姓氏列,如下面的屏幕快照所示。 這裡有一些棘手的方法可以幫助您解決此問題。
  • 在Excel中將長列拆分為多列
  • 如果您在Excel中有很長的列數據,則在查看它們時會很麻煩。 但是現在,如果您可以在Excel中將如此長的列表拆分為多個列,則將使查看變得很方便。

 


  • 超級公式欄 (輕鬆編輯多行文本和公式); 閱讀版式 (輕鬆讀取和編輯大量單元格); 粘貼到過濾範圍...
  • 合併單元格/行/列 和保存數據; 拆分單元格內容; 合併重複的行和總和/平均值...防止細胞重複; 比較範圍...
  • 選擇重複或唯一 行; 選擇空白行 (所有單元格都是空的); 超級查找和模糊查找 在許多工作簿中; 隨機選擇...
  • 確切的副本 多個單元格,無需更改公式參考; 自動創建參考 到多張紙; 插入項目符號,複選框等...
  • 收藏并快速插入公式,範圍,圖表和圖片; 加密單元 帶密碼 創建郵件列表 並發送電子郵件...
  • 提取文字,添加文本,按位置刪除, 刪除空間; 創建和打印分頁小計; 在單元格內容和註釋之間轉換...
  • 超級濾鏡 (將過濾方案保存並應用於其他工作表); 高級排序 按月/週/日,頻率及更多; 特殊過濾器 用粗體,斜體...
  • 結合工作簿和工作表; 根據關鍵列合併表; 將數據分割成多個工作表; 批量轉換xls,xlsx和PDF...
  • 數據透視表分組依據 週號,週幾等 顯示未鎖定的單元格 用不同的顏色 突出顯示具有公式/名稱的單元格...
kte選項卡201905
  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
  • 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
  • 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!
officetab底部

 

Comments (13)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Thank you very much.....
This comment was minimized by the moderator on the site
Super Sache

Frage:

Ist es möglich die Tabelle immer neu zu füllen und neu zu berechnen.
Bin absoluter anfänger. :-)
Danke im Voraus
This comment was minimized by the moderator on the site
Hello, Lukas,
I'm sorry, the methods in this article can't support to update the new data when the original data is changed.
So, you need to run the code again to get the latest data if there are changes in your data.
Thank you!
This comment was minimized by the moderator on the site
I can't get this macro to work (Split A Large Table Into Multiple Tables Based On Column Value With VBA Code)
My table has 5 columns and 639,165 rows. Is it too big?
This comment was minimized by the moderator on the site
Hello, Rebekah

If the data is too large, the code will not work perfectly.
Here, I recommend our Kutools for Excel' Split Data feature for you. With this feature, you can split large data to multiple sheets quickly and easily.
You can try it for 30 days freely. Please download it ffrom: https://www.extendoffice.com/download/kutools-for-excel.html
Please have a try, hope it can help you!
This comment was minimized by the moderator on the site
Hallo zusammen. Ich habe das gleiche Problem wie cGast - gibt es dazu eine Lösung?
This comment was minimized by the moderator on the site
Hi, Miriam,

The VBA code has been updated to a new one in this article, please try it again, if you have any other problem, please comment here. Thank you!
This comment was minimized by the moderator on the site
I tried "Split a large table into multiple tables based on the specific number of rows with VBA code" with my data of 103,000 rows split in groups of 15000 which should have returned 8 sheets, however it didnt work, it just produced 8 sheets with the headers only. but it does work when i use it with less that 10000rows. any help there?
This comment was minimized by the moderator on the site
Hello cguest,
Yes, as you said, the VBA code does not work correctlly when there are lots of data, here, I provide a new code, please try:
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


Hope it can help you, Thank you!
There are no comments posted here yet
Load More
Leave your comments
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations