[已解决]根据部门拆分表至工作簿

电子表

根据部门拆分表格内容至工作簿，每个部门独立工作簿，以部门来命名。要求格式与表格式相同。请论坛的朋友帮忙看看，谢谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2014-11-20 15:27

Sub Click()
    Dim r&, f$, p$
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p = ThisWorkbook.Path & "\"
    r = Range("a65536").End(xlUp).Row
    Do While r <> 1
        r = Cells(r, 1).End(xlUp).Row
        f = Cells(r, 1)
        Cells(r, 1).CurrentRegion.Copy
        Workbooks.Add
        ActiveSheet.Paste
        ActiveWorkbook.SaveAs p & f
        ActiveWorkbook.Close
        r = Cells(r, 1).End(xlUp).Row
    Loop
    MsgBox "ok"
End Sub

根据部门内容拆分表格至工作簿2.rar (14.71 KB, 下载次数: 41)

2014-11-20 15:27 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

请重新上传附件

Excel学徒123

这基表做的简直不能提

电子表

根据部门内容拆分表格至工作簿.rar (8.49 KB, 下载次数: 9)

2014-11-20 15:13 上传

点击文件名下载附件 麻烦帮忙看看！

爱疯

Sub Click()
    Dim r&, f$, p$
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p = ThisWorkbook.Path & "\"
    r = Range("a65536").End(xlUp).Row
    Do While r <> 1
        r = Cells(r, 1).End(xlUp).Row
        f = Cells(r, 1)
        Cells(r, 1).CurrentRegion.Copy
        Workbooks.Add
        ActiveSheet.Paste
        ActiveWorkbook.SaveAs p & f
        ActiveWorkbook.Close
        r = Cells(r, 1).End(xlUp).Row
    Loop
    MsgBox "ok"
End Sub

根据部门内容拆分表格至工作簿2.rar (14.71 KB, 下载次数: 41)

2014-11-20 15:27 上传

点击文件名下载附件

dsmch

Sub Macro1()
Dim wb As Workbook, arr, brr, i&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = GetObject(ThisWorkbook.Path & "\1.xls")
arr = wb.Sheets(1).UsedRange
wb.Close 0
For i = 1 To UBound(arr)
    If arr(i, 1) Like "*部门" Then
        s = s + 1
        With Workbooks.Open(Filename:=ThisWorkbook.Path & "\1.xls")
            .Sheets(1).Activate
            n = Cells(i + 1, 1).CurrentRegion.Rows.Count
            If s = 1 Then GoTo 100
            Cells(i + 1, 1).CurrentRegion.Copy .Sheets(1).[a2]
100:
            Cells(n + 2, 1).Resize(20000, 100).Clear
            .SaveAs Filename:=ThisWorkbook.Path & "\" & arr(i, 1) & ".xls"
            Workbooks(arr(i, 1)).Close 1
        End With
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

dsmch

若要格式完全相同，通过一工作簿操作拆分工作簿，另存为

电子表

dsmch 发表于 2014-11-20 17:14
若要格式完全相同，通过一工作簿操作拆分工作簿，另存为

dsmch好思路，我还要消化一下！谢谢您的指导！如果用这种方法生成一样的格式，部门名称没有什么共同点，是否应考虑用序号比较合适！

dsmch

爱疯 发表于 2014-11-20 15:27
Sub Click()
    Dim r&, f$, p$
    Application.ScreenUpdating = False

这种方法并不能实现格式完全相同，如列宽、行高等

爱疯

dsmch 发表于 2014-11-20 19:56
这种方法并不能实现格式完全相同，如列宽、行高等

谢谢！是的，要单独复制行高和列宽