使用vba根据Excel中的列将一个工作表中的数据拆分为多个工作表

我正在尝试根据单元格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

---

以下是一个优化程度稍低但更易于遵循的版本：

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

Private子命令按钮1\u单击（）
将ws作为工作表，c作为范围
作为工作表的Dim temp，作为范围的CostC，u
设置ws=图纸（“图纸1”）
Set CostC=ws.Range（ws.Range（“A3”）、ws.Range（“A”和Rows.Count）.End（xlUp））
对于肋软骨细胞中的每个c
u=微调（c值）
如果len（u）>0，则
设置temp=Nothing'使用
ColumnDifferences
方法返回一个范围，然后使用该范围的
Areas（1）
属性将数据复制到一个新的工作表中，然后您可以删除数据并重复，或循环区域并复制它们。
您尝试过更改任何代码吗？看起来和2008年发布的完全一样。也许首先自己动手修改它以满足您的需要？是的，我已经修改了单元格位置。我尝试使用If CostC“”跳过空单元格，但出现了运行时错误。是空的名称单元格，还是整行？整行。示例A5之间的A1到A10是空的，它只会将值从A1粘贴到A4。Mate，基于此代码，它只打开一张工作表，并将所有内容编译到该工作表中。我想做的是根据单元格A3中的名称打开多个工作表。名字可以是重复的例子约翰，简和杰克。如果工作表1中的名称是John，并且它的出现次数是John之后的新工作表名称的10倍，并且还会在单元格b、c等中复制年龄大小。我的问题是，如果单元格中间为空，我无法跟踪数据。例如，如果单元格A20为空，则它将根据名称在新的工作表中仅显示单元格A19之前的数据。请参阅我的编辑-我应该在以前的版本中添加“未测试”。-）