如何拆分工作表

xun_1221

求助大神，如何拆分工作表，同时新生成的表格名称命名为：区域+人员名称+人员编号。


比如第一行拆分之后文件名称是：A+小芳+161015，表格内容如下：

第二行拆分之后文件名称是：A+小强+300908，表格内容如下：

lizhipei78

https://club.excelhome.net/threa ... tml?_dsign=59ea1e22
通用，以后不求人，就是命名没有符合你的要求，对拆分应该是没有问题的

洋务德雷

一条记录一个工作表的话，用邮件合并是不是比较好

沈默00

沈默00

试一下.....

limonet

关键字：getrows

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, Rst As Object, Rst1 As Object
    Set Cn = CreateObject("Adodb.Connection")
    Set Rst = CreateObject("adodb.recordset")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select * From [Sheet1$A3:R]"
    Rst.Open StrSQL, Cn, 1, 3
    Set Rst1 = Cn.Execute(StrSQL)
    ReDim Arr(1 To Rst.RecordCount, 1 To 2)
    For i = 1 To Rst.RecordCount
        Arr(i, 1) = Join(Application.Transpose(Rst.GetRows(1)), "+")
        Arr(i, 2) = "\" & Join(Application.Transpose(Rst1.GetRows(1, , Array("F2", "F3", "F5"))), "+") & ".xlsm"
    Next i
    Range("A4:S99").Clear
    For i = 1 To UBound(Arr)
        Range("A3").Resize(1, 18) = Split(Arr(i, 1), "+")
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & Arr(i, 2)
    Next i
End Sub

limonet

关键字：GetRows+saveas

limonet

Sub limonet()
    Application.ScreenUpdating = False
    Dim Cn As Object, StrSQL$, Arr As Variant, Rst As Object, Rst1 As Object
    Set Cn = CreateObject("Adodb.Connection")
    Set Rst = CreateObject("adodb.recordset")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select * From [Sheet1$A3:R]"
    Rst.Open StrSQL, Cn, 1, 3
    Set Rst1 = Cn.Execute(StrSQL)
    For i = 1 To Rst.RecordCount
        Workbooks.Add
        Workbooks("工作表拆分").ActiveSheet.Range("A1:S2").Copy Workbooks(2).ActiveSheet.Range("A1")
        Range("A3").Resize(1, 18) = Application.Transpose(Rst.GetRows(1))
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Join(Application.Transpose(Rst1.GetRows(1, , Array("F2", "F3", "F5"))), "+") & ".xlsx"
        ActiveWorkbook.Close
    Next i
    Application.ScreenUpdating = True
End Sub

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.10
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     arr = sh.UsedRange
   
9.     For i = 3 To UBound(arr)
   
10.         s = arr(i, 6)
    
11.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.         d(s)(i) = i
    
13.     Next
    
14.     For Each k In d.keys
    
15.         sh.Copy
    
16.         Set wb = ActiveWorkbook
    
17.         m = 0
    
18.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
19.         With wb.Sheets(1)
    
20.             .Name = k
    
21.             .DrawingObjects.Delete
    
22.             .UsedRange.Offset(2 + d(k).Count).Clear
    
23.             For Each kk In d(k).keys
    
24.                 fn = arr(kk, 2) & "+" & arr(kk, 3) & "+" & arr(kk, 5)
    
25.                 m = m + 1
    
26.                 brr(m, 1) = m
    
27.                 For j = 2 To UBound(arr, 2)
    
28.                     brr(m, j) = arr(kk, j)
    
29.                 Next
    
30.             Next
    
31.         End With
    
32.         wb.SaveAs p & fn
    
33.         wb.Close 1
    
34.     Next
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码