拆分Excel工作表为基于多个文件柱上使用VBA
|您是否在excel工作表上有大数据，并且需要根据一列中的一些数据将该工作表分布在多个工作表中？这是非常基本的任务，但很耗时。
例如，我有此数据。该数据具有名为日期，作者和标题的列。 Writer列具有相应标题的作家姓名。我想在单独的表格中获取每个作者的数据。
要手动执行此操作，我必须执行以下操作：
。过滤一个名称。复制过滤的数据。添加工作表。粘贴数据。重命名工作表。重复上述所有5个步骤。
在这个例子中，我只有三个名字。想象一下，如果有100个名字。
您如何将数据分成不同的工作表？这将花费很多时间，并且也会消耗您的精力。
若要自动完成上述将工作表拆分为多个工作表的过程，请按照下列步骤操作。
按Alt + F11。这将为Excel打开VB编辑器。添加新模块*在模块下面的代码下面复制。
Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim uniques As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set uniques = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set uniques = RemoveDuplicates(uniques)
Call CreateSheets(uniques, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(uniques As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "uniques"
Sheets("uniques").Activate
On Error GoTo 0
uniques.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "uniques"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(uniques As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long
For Each unique In uniques
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next unique
End Sub
当您运行SplitIntoSheets（）过程时，工作表将根据给定的列分为多个工作表。您可以在工作表上添加按钮并将此宏分配给它。
工作原理
上面的代码有两个过程和一个功能。有两个过程是SplitIntoSheets（），CreateSheets（唯一性为范围，clmNo为长），一个功能是RemoveDuplicates（唯一性为范围）作为范围。第一个过程是SplitIntoSheets（）。这是主要过程。此过程将变量和RemoveDuplicates设置为从给定的列中获取唯一的名称，然后将这些名称传递给CreateSheets以创建工作表。
RemoveDuplicates采用一个参数，该参数是包含名称的范围。
从它们中删除重复项，并返回包含唯一名称的范围对象。
现在调用CreateSheets。它有两个参数。首先是唯一名称，其次是列号。从中我们可以拟合数据。现在，CreateSheets从唯一性中获取每个名称，并按每个名称过滤给定的列号。复制过滤的数据，添加工作表并将数据粘贴到此处。然后，您的数据将在几秒钟内分裂成不同的表格。
您可以在此处下载文件。
拆分为表格
如何使用文件：
-
将数据复制到Sheet1上。确保它从A1开始。
单击按钮拆分为表格*输入要拆分的列字母。单击确定。
-
您会看到这样的提示。您的工作表已拆分。
我希望有关将数据分成单独的工作表的文章对您有所帮助。如果对此有任何疑问或对excel的任何其他功能有任何疑问，请随时在下面的评论部分中提问。