一个工作簿分成多个工作簿

swon2010

一个工作簿分成多个工作簿

quqiyuan

参与一下，供参考。。。

3190496160

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

3190496160

新建文件夹.rar (13.63 KB, 下载次数: 5)

2024-7-12 13:10 上传

点击文件名下载附件

swon2010

赞赞

swon2010

可以，可以，已经解决了问题了，很方便

gwjkkkkk

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

gwjkkkkk

...........

ykcbf1100

总表按区块拆分为多工作簿

ykcbf1100

原格式拆分

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
    

复制代码