vba 使用vba根据Excel中的列将一个工作表中的数据拆分为多个工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19557764/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Split data in one worksheet to multiple worksheets based on column in Excel using vba
提问by user2766881
I am trying to split data in sheet 1 to multiple sheets based on the name column in cell A3 onwards. The problem that I am facing is I'm unable to track down the data if there are gap in between. Example the name starts from A3 to A100 and in between cell A10, A20 & A30 is empty the program will only track down value from A3 to A9. The other problem for me is to specify the header. The header that I want to use start from cell A2, B2, C2 & D2 and this program show the header as A1, B1, C1 & D1 as there are value in that cell. This is my code.
我正在尝试根据单元格 A3 中的名称列将工作表 1 中的数据拆分为多个工作表。我面临的问题是，如果两者之间存在差距，我将无法追踪数据。示例名称从 A3 开始到 A100，并且在单元格 A10、A20 和 A30 之间为空，程序将仅跟踪从 A3 到 A9 的值。我的另一个问题是指定标题。我想使用的标题从单元格 A2、B2、C2 和 D2 开始，该程序将标题显示为 A1、B1、C1 和 D1，因为该单元格中有值。这是我的代码。
Private Sub CommandButton1_Click()
Dim ws As Worksheet, Rng As Range, cc
Dim temp As Worksheet, CostC As Range, u
Set ws = Sheets("Sheet1") 'where your original data. adjust to suit
Set Rng = ws.Range("a1").CurrentRegion.Resize(, 15)
Set CostC = ws.Range("a3", ws.Range("a" & Rows.Count).End(xlUp))
u = UNIQUE(CostC)
Application.ScreenUpdating = 0
For Each cc In u
With Rng
.AutoFilter field:=1, Criteria1:="=" & cc
On Error Resume Next
Set temp = Sheets(cc)
On Error GoTo 0
If Not temp Is Nothing Then
DoThis:
.SpecialCells(xlCellTypeVisible).Copy temp.Range("A1")
Else
Set temp = Sheets.Add
temp.Name = cc
GoTo DoThis
End If
.AutoFilter
End With
Set temp = Nothing
Next
Application.ScreenUpdating = 1
End Sub
Function UNIQUE(r As Range)
Dim a, v
If IsArray(r.Value) Then
a = r.Value
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For Each v In a
If Not IsEmpty(v) Then
If Not .exists(v) Then .Add v, Nothing
End If
Next
If .Count > 0 Then UNIQUE = .keys
End With
Erase a
Else
UNIQUE = r.Value
End If
End Function
采纳答案by Tim Williams
Here's a slightly less-optimized but simpler to follow version:
这是一个稍微不那么优化但更易于遵循的版本：
Private Sub CommandButton1_Click()
Dim ws As Worksheet, c As Range
Dim temp As Worksheet, CostC As Range, u
Set ws = Sheets("Sheet1")
Set CostC = ws.Range(ws.Range("A3"), ws.Range("A" & Rows.Count).End(xlUp))
For each c in CostC.Cells
u = trim(c.Value)
If len(u) > 0 then
Set temp = Nothing '<<EDIT
On Error Resume Next
Set temp = Sheets(u)
On Error GoTo 0
If temp is Nothing then
Set temp = Sheets.Add()
ws.Range("A2").Resize(1, 15).Copy temp.range("a1") 'copy headers
temp.Name = u
End If
c.resize(1, 15).copy temp.cells(rows.count,1).end(xlup).offset(1,0)
End if 'have name
Next c
End Sub
回答by Mr. Mascaro
Use the ColumnDifferencesmethod to return a range and then use the Areas(1)property of that range to copy the data into a new worksheet and then you can delete the data and repeat, or loop through the areas and copy them.
使用该ColumnDifferences方法返回一个范围，然后使用该范围的Areas(1)属性将数据复制到新的工作表中，然后您可以删除数据并重复，或遍历区域并复制它们。
