ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 285|回复: 9

[求助] 一个工作簿分成多个工作簿

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-7-12 10:32 | 显示全部楼层 |阅读模式
一个工作簿分成多个工作簿

book1.zip

3.09 KB, 下载次数: 21

TA的精华主题

TA的得分主题

发表于 2024-7-12 13:01 | 显示全部楼层
参与一下,供参考。。。
image.png
image.png
image.png

book1(3).zip

17.76 KB, 下载次数: 5

TA的精华主题

TA的得分主题

发表于 2024-7-12 13:09 | 显示全部楼层
Sub 拆分为工作簿()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空!": End
    ar = .Range("a1:b" & r)
    ReDim br(1 To UBound(ar), 1 To 1)
    For i = 1 To UBound(ar)
        If ar(i, 1) <> "" Then
            ia = Left(ar(i, 1), 1)
            If ia Like "[a-zA-Z]" Then
                m = m + 1
                br(m, 1) = i
            End If
        End If
    Next i
    m = m + 1
    br(m, 1) = r
    Application.SheetsInNewWorkbook = 1
    For i = 1 To m - 1
        ks = br(i, 1)
        js = br(i + 1, 1) - 1
        Set rn = .Rows(ks & ":" & js)
        Set wb = Workbooks.Add
        rn.Copy wb.Worksheets(1).[a1]
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ar(ks, 1) & ".xlsx"
        wb.Close
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

TA的精华主题

TA的得分主题

发表于 2024-7-12 13:10 | 显示全部楼层
新建文件夹.rar (13.63 KB, 下载次数: 5)

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-7-12 17:34 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-7-12 17:34 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2024-7-12 20:21 | 显示全部楼层

Option Explicit

Sub TEST2()
    Dim ar, br(), i&, j&, p&, r&, strFileName$, Rng As Range
   
    Application.DisplayAlerts = False
   
    With ActiveSheet.UsedRange
        .Interior.Color = xlNone
        ar = .Value: p = 1
        
        For i = 2 To UBound(ar)
            If i = UBound(ar) Then
                 r = r + 1
                 ReDim Preserve br(1 To 2, 1 To r)
                 br(1, r) = p: br(2, r) = i
            Else
                If ar(i + 1, 1) Like "A*" Then
                    r = r + 1
                    ReDim Preserve br(1 To 2, 1 To r)
                    br(1, r) = p: br(2, r) = i
                    p = i + 1
                End If
            End If
        Next i
        For j = 1 To UBound(br, 2)
            strFileName = ThisWorkbook.Path & "\" & ar(br(1, j), 1)
            Set Rng = .Cells(br(1, j), 1).Resize(br(2, j) - br(1, j) + 1, UBound(ar, 2))
            With Workbooks.Add
                 Rng.Copy .Worksheets(1).[A1]
                 .SaveAs strFileName
                 .Close
            End With
        Next j
    End With
   
    Application.DisplayAlerts = True
    Beep
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-7-12 20:23 | 显示全部楼层
...........

新建文件夹.rar

13.08 KB, 下载次数: 7

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-7-13 21:57 | 显示全部楼层
总表按区块拆分为多工作簿

Book1.zip

18.2 KB, 下载次数: 3

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-7-13 21:57 | 显示全部楼层
原格式拆分
  1. Sub 拆分()  '//2024.7.13   总表拆分为多工作簿
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     Set d = CreateObject("scripting.dictionary")
  5.     p = ThisWorkbook.Path & ""
  6.     With Sheets("Sheet1")
  7.         r = .Cells(Rows.Count, 1).End(3).Row
  8.         arr = Range("A1:d" & r)
  9.         On Error Resume Next
  10.         For i = 1 To r
  11.             If InStr(arr(i, 1), "A") Then k = k + 1: d(k) = i
  12.         Next
  13.         t = d.items
  14.         For k = 1 To d.Count
  15.             r1 = d(k)
  16.             If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
  17.             Set wb = Workbooks.Add
  18.             .Rows(r1 & ":" & r2).Copy wb.Sheets(1).[a1]
  19.             wb.Sheets(1).DrawingObjects.Delete
  20.             wb.SaveCopyAs p & .Cells(r1, 1).Value & ".xls"
  21.             wb.Close
  22.         Next
  23.     End With
  24.     Application.ScreenUpdating = True
  25.     MsgBox "OK!"
  26. End Sub
复制代码


评分

3

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-23 10:40 , Processed in 0.041139 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表