跳到主要內容

如何根據Excel中的列將數據拆分為多個工作表?

假設您有一個包含大量數據的工作表,現在,您需要根據以下內容將數據拆分為多個工作表: 姓名 列(請參見下面的屏幕截圖),然後隨機輸入名稱。 也許您可以先對它們進行排序,然後將它們一個一個地複制並粘貼到其他新工作表中。 但這需要您的耐心反复複製和粘貼。 今天,我將討論解決該任務的一些快速技巧。

doc按列1拆分數據

根據列使用VBA代碼將數據拆分為多個工作表

使用Kutools for Excel將數據基於列拆分為多個工作表


根據列使用VBA代碼將數據拆分為多個工作表

如果要基於列值快速自動地拆分數據,則以下VBA代碼是一個不錯的選擇。 請這樣做:

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

2。 點擊 插入 > 模塊,然後將以下代碼粘貼到“模塊窗口”中。

Sub Splitdatabycol()
'updateby 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
Dim xWS 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
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(i) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.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 鍵運行代碼,並彈出提示框,提醒您選擇標題行,請參見屏幕截圖:

doc按列7拆分數據

4。 然後,單擊 OK 按鈕,然後在第二個提示框中,選擇要基於其拆分的列數據,請參見屏幕截圖:

doc按列8拆分數據

5。 然後,點擊 OK,活動工作表中的所有數據均按列值劃分為多個工作表。 拆分工作表使用拆分單元格名稱命名。 看截圖:

doc按列2拆分數據

備註:拆分的工作表放在主工作表所在的工作簿的末尾。


使用Kutools for Excel將數據基於列拆分為多個工作表

作為一個Excel初學者,這種冗長的VBA代碼對我們來說有點困難,而且我們大多數人甚至都不知道如何根據需要修改代碼。 在這裡,我將向您介紹一個多功能工具-Excel的Kutools,其 拆分數據 該實用程序不僅可以幫助您根據列將數據拆分為多個工作表,還可以按行數拆分數據。

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

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

1。 選擇要拆分的數據范圍。

2。 點擊 Kutools 加 > 下載學習單 > 拆分數據,請參見屏幕截圖:

doc按列3拆分數據

3。 在 將數據拆分為多個工作表 對話框,您需要:

1)。 選擇 特定欄 在選項 分割依據 部分,然後在下拉列表中選擇要用於拆分數據的列值。 (如果您的數據包含標題,並且您想將其插入每個新的拆分工作表中,請檢查 我的數據有標題 選項。)

2)。 然後,您可以在 新工作表名稱 部分,從中指定工作表名稱規則 規則 下拉列表中,您可以添加 字首 or 後綴 以及工作表名稱。

3)。 點擊 OK 按鈕。 看截圖:

doc按列4拆分數據

4。 現在,數據被拆分為一個新的工作簿中的多個工作表。

doc按列5拆分數據

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


使用Kutools for Excel將數據基於列拆分為多個工作表

Excel的Kutools 包括300多個便捷的Excel工具。 30天免費試用,不受限制。 立即下載免費試用版!


相關文章:

如何按行數將數據拆分為多個工作表?

最佳辦公生產力工具

熱門特色: 尋找、突出顯示或識別重複項   |  刪除空白行   |  合併列或儲存格而不遺失數據   |   沒有公式的回合 ...
超級查詢: 多條件VLookup    多值VLookup  |   跨多個工作表的 VLookup   |   模糊查詢 ....
高級下拉列表: 快速建立下拉列表   |  依賴下拉列表   |  多選下拉列表 ....
欄目經理: 新增特定數量的列  |  移動列  |  切換隱藏列的可見性狀態  |  比較範圍和列 ...
特色功能: 網格焦點   |  設計圖   |   大方程式酒吧    工作簿和工作表管理器   |  資源庫 (自動文字)   |  日期選擇器   |  合併工作表   |  加密/解密單元格    按清單發送電子郵件   |  超級濾鏡   |   特殊過濾器 (過濾粗體/斜體/刪除線...)...
前 15 個工具集12 文本 工具 (添加文本, 刪除字符,...)   |   50+ 圖表 類型 (甘特圖,...)   |   40+ 實用 公式 (根據生日計算年齡,...)   |   19 插入 工具 (插入二維碼, 從路徑插入圖片,...)   |   12 轉化 工具 (數字到單詞, 貨幣兌換,...)   |   7 合併與拆分 工具 (高級合併行, 分裂細胞,...)   |   ... 和更多

使用 Kutools for Excel 增強您的 Excel 技能,體驗前所未有的效率。 Kutools for Excel 提供了 300 多種進階功能來提高生產力並節省時間。  點擊此處獲取您最需要的功能...

kte選項卡201905


Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆

  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
  • 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
  • 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!
Comments (312)
Rated 5 out of 5 · 2 ratings
This comment was minimized by the moderator on the site
Sub SplitDataByColWorkbook()
Dim lr As Long
Dim ws As Worksheet
Dim vcol 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
Dim xWS As Workbook
Dim wb As Workbook


Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' Assuming you want to work with the first sheet in the workbook

On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Select Header Rows", Type:=8)
If xTRg Is Nothing Then Exit Sub

On Error Resume Next
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Select Split Column", Type:=8)
If xVRg Is Nothing Then Exit Sub

vcol = xVRg.Column
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
Set xWS = Workbooks.Add
Else
Set xWS = Workbooks.Add
End If

Set xWSTRg = xWS.Sheets(1)
xTRg.Copy
xWSTRg.Range("A1").PasteSpecial Paste:=xlPasteValues
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) & ""
Set xWS = Workbooks.Add
Set xWSTRg = xWS.Sheets(1)
xTRg.Copy
xWSTRg.Range("A1").PasteSpecial Paste:=xlPasteValues
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWSTRg.Range("A" & (titlerow + xTRg.Rows.Count))
xWSTRg.Columns.AutoFit
xWS.SaveAs myarr(i) & ".xlsx" ' Change the file name as needed
xWS.Close SaveChanges:=False
Next

ws.AutoFilterMode = False
wb.Activate
Application.DisplayAlerts = True
End Sub
This comment was minimized by the moderator on the site
First of all, thank you for the macro.

I would like to ask if there is any way to maintain the column widths. My 'original' tab was completely formatted. However, after running the macro, it loses the column formatting and appears quite messy.

English is not my first language (sorry).

Thank you again!
Rated 5 out of 5
This comment was minimized by the moderator on the site
The original header is not copied in the split sheet.
This comment was minimized by the moderator on the site
This works wonderfully, thank you very much!!! Huge time-saver.
Rated 5 out of 5
This comment was minimized by the moderator on the site
Hello,

I am having a hard time getting this code to work. When I run it, it just creates a duplicate sheet and does not split columns into multiple sheets.

I do have values that exceed 31 characters as well as special characters such as "-" and "()" in my column, how can I account for that without a lot of manual changes?
This comment was minimized by the moderator on the site
This worked great!!! One question... my formulas didn't transfer to each sheet correctly. What do I need to do differently to transfer the formulas?
Thank you!!!!!
This comment was minimized by the moderator on the site
Nice code, but it just copied everything to the new tables, named correctly though. So, the data filtering did not work at all, just copy paste.
This comment was minimized by the moderator on the site
When I run this using a small amount of data like the example it works. I'm trying to use this on a database with 400k + rows of data. When I run the macro, a second tab is created with just the header row and no data.
This comment was minimized by the moderator on the site
Hello, Ryan,

As you mentioned, the code works well for small data ranges, if there are lots of data, the code will not work properly.
In such situations, I recommend using the "Split Data" feature offered by Kutools for Excel. This powerful feature can greatly assist you in managing large amounts of data. To take advantage of this feature, you can download and install Kutools for Excel, which is available for a 30-day free trial.

Please have a try, thank you!
This comment was minimized by the moderator on the site
I've come across many solutions in VBA message boards for parsing data into worksheets or columns based upon filtering a particular column, but they all require a bit of tinkering and customization. What makes this so brilliant is that it is dynamic, user-friendly even for beginners (which gives it shareable utility), and copy/paste ready.

You rock.
This comment was minimized by the moderator on the site
Hi, Dane,
Thanks for your comment, glad this can help you! Have a good day!
This comment was minimized by the moderator on the site
When I try to split data from a different sheet, it copies and pastes the entire sheet into one sheet instead of multiple sheets. Could this be because the naming convention of the sheet I'm trying to split is similar to another sheet?
This comment was minimized by the moderator on the site
Hello, Giancarlo,

If the data in the column is same with a sheet name in the workbook, the sheet with the same name will be kept, other data will be split into separate sheet.
Thanks for your comment.
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations