excel将一个工作表根据条件拆分成多个sheet工作表

向右看齐 2022-05-14 12:13 540阅读 0赞

本例介绍在excel中如何将一个工作表根据条件拆分成多个工作表。
    
    注意：很多朋友反映sheets(i).delete这句代码出错，要注意下面第一个步骤，要拆分的数据工作表名称为“数据源”，
     而不是你新建工作簿时的sheet1这种。手动改成“数据源”即可。或者是把代码中得"数据源"改为你得源工作表“Sheet1”也行

先展示最后效果：  
![这里写图片描述][70]  
![这里写图片描述][70 1]

## 开始步骤例子： ##

1.  ![列表内容][70 2]
2.  ![这里写图片描述][70 3]
3.  ![这里写图片描述][70 4]
4.  ![这里写图片描述][70 5]
5.  代码如下

Sub CFGZB()
    
        Dim myRange As Variant
    
        Dim myArray
    
        Dim titleRange As Range
    
        Dim title As String
    
        Dim columnNum As Integer
    
        myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
    
        myArray = WorksheetFunction.Transpose(myRange)
    
        Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)
    
        title = titleRange.Value
    
        columnNum = titleRange.Column
    
        Application.ScreenUpdating = False
    
        Application.DisplayAlerts = False
    
        Dim i&, Myr&, Arr, num&
    
        Dim d, k
    
        For i = Sheets.Count To 1 Step -1
    
            If Sheets(i).Name <> "Sheet1" Then
                 Sheets(i).Delete
    
            End If
    
        Next i
    
        Set d = CreateObject("Scripting.Dictionary")
    
        Myr = Worksheets("Sheet1").UsedRange.Rows.Count
    
        Arr = Worksheets("Sheet1").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    
        For i = 1 To UBound(Arr)
    
            d(Arr(i, 1)) = ""
    
        Next
    
        k = d.keys
    
        For i = 0 To UBound(k)
    
            Set conn = CreateObject("adodb.connection")
    
            conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
    
            Sql = "select * from [Sheet1$] where " & title & " = '" & k(i) & "'"
    
            Worksheets.Add after:=Sheets(Sheets.Count)
    
            With ActiveSheet
    
                .Name = k(i)
    
                For num = 1 To UBound(myArray)
    
                    .Cells(1, num) = myArray(num, 1)
    
                Next num
    
                .Range("A2").CopyFromRecordset conn.Execute(Sql)
    
            End With
    
            Sheets(1).Select
    
            Sheets(1).Cells.Select
    
            Selection.Copy
    
            Worksheets(Sheets.Count).Activate
    
            ActiveSheet.Cells.Select
    
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                   SkipBlanks:=False, Transpose:=False
    
            Application.CutCopyMode = False
    
        Next i
    
        conn.Close
    
        Set conn = Nothing
    
        Application.DisplayAlerts = True
    
        Application.ScreenUpdating = True
    
    End Sub

6.![这里写图片描述][70 6]  
7.![在这里插入图片描述][70 7]  
8.![这里写图片描述][70 8]  
9.![这里写图片描述][70 9]  
10![这里写图片描述][70 10]  
![这里写图片描述][70 11]  
11.![这里写图片描述][70 12]  
12注意：

1）原始数据表要从第一行开始有数据，并且不能有合并单元格；

2）打开工作簿时需要开启宏，否则将无法运行代码。

[70]: /images/20220514/7cc9ef967814430bbdb05e714443b2c3.png
[70 1]: /images/20220514/d4bf83dab4c04595ab059316712d4a8e.png
[70 2]: /images/20220514/e96de7b0b5b14f1d940ba4e8fb4dc0c6.png
[70 3]: /images/20220514/c9a3431824d049338a627fcb4632f523.png
[70 4]: /images/20220514/9b574896aadd4ed0a0b9fbeecb494dd3.png
[70 5]: /images/20220514/f50c629959d8425cbc6cb7d00ef73e0c.png
[70 6]: /images/20220514/73211208802246d5a81ce40484fce013.png
[70 7]: /images/20220514/56eced4216dd4b4dbb146f81df0ab825.png
[70 8]: /images/20220514/923f3ee37a824c708bec86216063ca06.png
[70 9]: /images/20220514/d6829baf071d49aaaf2a9333861930ee.png
[70 10]: /images/20220514/bd4705941216494f95625eb738c9871c.png
[70 11]: /images/20220514/3cccc46e2191413694e326b3ac026e58.png
[70 12]: /images/20220514/774c4e0f56c74a2ab684b2560b359729.png