一个工作表按照姓名拆分为多个工作表

共和国方面

将表内的数据表按照姓名拆分为多个工作表，大侠帮我一下，谢谢

约定的童话

模拟一下拆分后的格式

everbest2015

Sub CFGZB()

    Dim myRange As Variant

    Dim myArray

    Dim titleRange As Range, r As Range

    Dim title As String, n&

    Dim columnNum As Integer
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("数据源")
    myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)
    n = sh.Cells(Rows.Count, "a").End(xlUp).Row
    Set r = sh.Range("a2:n" & n)
    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 <> "数据源" Then

            Sheets(i).Delete

        End If

    Next i

    Set d = CreateObject("Scripting.Dictionary")

    Myr = Worksheets("数据源").UsedRange.Rows.Count

    Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))

    For i = 2 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 [数据源$a2:n] 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


        r.Copy


        Worksheets(Sheets.Count).Activate

        ActiveSheet.UsedRange.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

xiangbaoan

Option Explicit
Sub test()
Dim d As Object, ar, s$, i%, c%, sh As Worksheet
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Name <> "数据源" Then sh.Delete
Next
Application.DisplayAlerts = True
ReDim br(1 To 14)
With Sheets("数据源")
    For i = 1 To 14
        br(i) = .Columns(i).ColumnWidth
    Next
    ar = .Range("g1:g" & .Cells(.Rows.Count, 7).End(xlUp).Row)
    For i = 3 To UBound(ar)
        s = ar(i, 1)
        If Len(s) Then
            If Not d.exists(s) Then Set d(s) = .[a1].Resize(2, 14)
            Set d(s) = Union(d(s), .Cells(i, 1).Resize(1, 14))
        End If
    Next
End With
For i = 0 To d.Count - 1
    Sheets.Add after:=Sheets(Sheets.Count)
    With ActiveSheet
        For c = 1 To 14
            .Columns(c).ColumnWidth = br(c)
        Next
        .Name = d.keys()(i)
        d.items()(i).Copy .[a1]
    End With
Next
Sheets("数据源").Activate
Set d = Nothing
Application.ScreenUpdating = False
End Sub

xiangbaoan

……测试……

zhanghai0602

1. Sub test()
   
2.     Dim c As Object, r As Object, rs As Object, sql$, i%, T!
   
3.     Application.ScreenUpdating = False
   
4.     Set c = CreateObject("adodb.connection")
   
5.     Set rs = CreateObject("ADODB.Recordset")
   
6.    
   
7.     If Application.Version >= 12 Then
   
8.         c.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
9.     Else
   
10.         c.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    
11.     End If
    
12.     rs.Open "Select distinct 账户名 from [数据源$G2:G] where 账户名 is not null", c
    
13.     Do While Not rs.EOF
    
14.         Set r = CreateObject("ADODB.Recordset")
    
15.         jb rs(0)
    
16.         sql = "select * from [数据源$A2:N] where 账户名='" & rs(0) & "'"
    
17.         r.Open sql, c
    
18.         For i = 0 To r.Fields.Count - 1
    
19.             Cells(1, i + 1) = r(i).Name
    
20.         Next
    
21.         Range("A2").CopyFromRecordset r
    
22.         Cells.EntireColumn.AutoFit
    
23.         Set r = Nothing
    
24.         rs.MoveNext
    
25.     Loop
    
26.     Set rs = Nothing
    
27.     Set c = Nothing
    
28.     Sheets("数据源").Select
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    
31. Sub jb(sn$)
    
32.     On Error Resume Next
    
33.     Application.DisplayAlerts = False
    
34.     Sheets(sn).Delete
    
35.     Sheets.Add , Sheets(Sheets.Count)
    
36.     ActiveSheet.Name = sn
    
37. End Sub

复制代码

ADO方式

everbest2015

3楼的循环装入列宽的思路不错了学习了

everbest2015

Sub 拆分工作表()
    Dim sh As Worksheet, ar, br(), d As Object, i&, r&, j As Byte, s$, k, rg As Range
    With ThisWorkbook
        Application.DisplayAlerts = False
            If .Sheets.Count > 1 Then
                For Each sh In .Worksheets
                    If sh.Name <> "数据源" Then sh.Delete
                Next
            End If
        Application.DisplayAlerts = True
    End With
    Set sh = ThisWorkbook.Sheets("数据源")
    r = sh.Cells(Rows.Count, "g").End(3).Row
    If r > 2 Then
        ar = sh.Range("a2:n" & r)
        Set rg = ThisWorkbook.Sheets(1).Range("a2:n2")
        ReDim br(1 To UBound(ar, 2))
        For j = 1 To UBound(ar, 2)
            br(j) = sh.Columns(j).ColumnWidth
        Next
        Set d = CreateObject("scripting.dictionary")
    Else
        End
    End If
    For i = 2 To UBound(ar)
        s = ar(i, 7)
       If s <> "" Then
            If Not d.exists(s) Then
                Set d(s) = sh.Range("a" & i + 1).Resize(, 14)
            Else
                Set d(s) = Union(d(s), sh.Range("a" & i + 1).Resize(, 14))
            End If
       End If
    Next
    If d.Count > 0 Then
        Application.ScreenUpdating = False
            For Each k In d.keys
                Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
                sh.Name = k
                rg.Copy sh.Range("a1")
                d(k).Copy sh.Range("a2")
                For j = 1 To 14
                    sh.Columns(j).ColumnWidth = br(j)
                Next
            Next
        Application.ScreenUpdating = True
    End If
End Sub

everbest2015

最后一个next 上面加一句 sh.UsedRange.EntireRow.AutoFit  貌似效果会好看点，具体请见代码

Sub 拆分工作表()
    Dim sh As Worksheet, ar, br(), d As Object, i&, r&, j As Byte, s$, k, rg As Range
    With ThisWorkbook
        Application.DisplayAlerts = False
            If .Sheets.Count > 1 Then
                For Each sh In .Worksheets
                    If sh.Name <> "数据源" Then sh.Delete
                Next
            End If
        Application.DisplayAlerts = True
    End With
    Set sh = ThisWorkbook.Sheets("数据源")
    r = sh.Cells(Rows.Count, "g").End(3).Row
    If r > 2 Then
        ar = sh.Range("a2:n" & r)
        Set rg = ThisWorkbook.Sheets(1).Range("a2:n2")
        ReDim br(1 To UBound(ar, 2))
        For j = 1 To UBound(ar, 2)
            br(j) = sh.Columns(j).ColumnWidth
        Next
        Set d = CreateObject("scripting.dictionary")
    Else
        End
    End If
    For i = 2 To UBound(ar)
        s = ar(i, 7)
       If s <> "" Then
            If Not d.exists(s) Then
                Set d(s) = sh.Range("a" & i + 1).Resize(, 14)
            Else
                Set d(s) = Union(d(s), sh.Range("a" & i + 1).Resize(, 14))
            End If
       End If
    Next
    If d.Count > 0 Then
        Application.ScreenUpdating = False
            For Each k In d.keys
                Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
                sh.Name = k
                rg.Copy sh.Range("a1")
                d(k).Copy sh.Range("a2")
                For j = 1 To 14
                    sh.Columns(j).ColumnWidth = br(j)
                Next
                sh.UsedRange.EntireRow.AutoFit
            Next
        Application.ScreenUpdating = True
    End If
End Sub