楼主
0Mouse |
示例要求：把“展开层”这一列（A列）里面每一段以“....4”这一行开头的区域单独提取出来存到一个新的工作表里，分别以“....4”行里面“组件”列（E列）的单元格内容命名，保存在此表所在的文件夹下。
源数据：
拆分后文件目录：
生成的文件之一：
代码如下：- Sub 工作表拆分成多个工作簿()
- Application.ScreenUpdating = False
- Dim arr, brr, crr, i%, j%, k%, x%, fn$
- Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = 4 'A列最后一个单元格的下一个单元格写上4，作为最后一段数据的提取结束标志
- arr = [A1].CurrentRegion
- brr = [A1].Resize(2, UBound(arr, 2))
- ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
- For i = 3 To UBound(arr)
- If arr(i, 1) Like "*4" Then '判断结尾是否为4
- k = k + 1
- If k = 1 Then
- x = x + 1
- For j = 1 To UBound(arr, 2)
- crr(x, j) = arr(i, j)
- Next
- fn = arr(i, 5)
- End If
- If k = 2 Then
- Worksheets.Add(, Sheets(Sheets.Count)).Name = fn
- With ActiveSheet
- .[A1].Resize(2, UBound(arr, 2)).Value = brr
- .[A3].Resize(x, UBound(arr, 2)).Value = crr
- .[A1].Select
- .Move '将工作表移动到一个新的工作簿
- End With
- ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & fn & ".xlsx", FileFormat:=51
- ActiveWorkbook.Close False
- ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
- For j = 1 To UBound(arr, 2)
- crr(1, j) = arr(i, j)
- Next
- fn = arr(i, 5)
- k = 1
- x = 1
- End If
- Else
- If k = 1 Then
- x = x + 1
- For j = 1 To UBound(arr, 2)
- crr(x, j) = arr(i, j)
- Next
- End If
- End If
- Next
- Cells(Rows.Count, 1).End(xlUp).ClearContents '删除A列之前添加的那个4
- Application.ScreenUpdating = True
- End Sub
附件：
 运用VBA按照特定条件将工作表拆分成多个工作簿的一个实例.rar
|
2楼
纵鹤擒龙水中月 |
学海无涯 |
3楼
qinhuan66 |
好好学习天天向上 |
4楼
LOGO |
昨晚在家里折腾了好久才写出来下面这段代码，新手伤不起啊！。
尝试了用数组构造辅助列+高级筛选来拆分，但速度有点慢。
也尝试了在原表通过筛选来进行复制粘贴来拆分，速度也有点慢。后来还是下面这段速度自己觉得还算满意- Sub 分段拆分()
- Dim dic As Object, arr, brr, crr(), rng As Range, i As Integer, T, n%, P, r%, c%
- Set dic = CreateObject("scripting.dictionary")
- arr = [a1].CurrentRegion
- brr = [a1].Resize(2, UBound(arr, 2))
- Application.ScreenUpdating = False
- For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
- If Cells(i, 1) Like "*4" Then dic(Cells(i, 1).Row) = ""
- Next
- dic(Cells(UBound(arr), 1).Row + 1) = ""
- T = dic.keys
- For n = 0 To dic.Count - 2
- dic.RemoveAll
- ReDim crr(1 To T(n + 1) - T(n), 1 To UBound(arr, 2))
- For r = 1 To T(n + 1) - T(n): For c = 1 To UBound(arr, 2)
- crr(r, c) = arr(T(n) + r - 1, c)
- Next
- Next
- With Workbooks.Add.Sheets(1)
- [a1].Resize(2, UBound(arr, 2)) = brr
- [a3].Resize(UBound(crr), UBound(crr, 2)) = crr
- .Name = [e3]
- End With
- ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
- ActiveWorkbook.Close False
- Next
- Application.ScreenUpdating = True
- End Sub
|
5楼
LOGO |
通过筛选复制粘贴的代码如下：- Sub 筛选复制粘贴()
- Dim c As Integer, r As Integer, i As Integer, arr
- Application.ScreenUpdating = False
- arr = [a1].CurrentRegion
- r = UBound(arr)
- c = UBound(arr, 2)
- With Cells(3, c + 1).Resize(r - 2)
- .Value = "=countif(rc[" & -c & "]:r3c1,r3c1)"
- .Value = .Value
- End With
- For i = 1 To Application.Max(Cells(3, c + 1).Resize(r - 2, 1))
- Sheet1.[a1].AutoFilter c + 1, i
- Sheet1.[a1].CurrentRegion.Copy Workbooks.Add.Sheets(1).[a1]
- With ActiveSheet
- .Name = .[e3].Value
- .UsedRange.Columns(c + 1).Clear
- If .FilterMode Then Cells.AutoFilter
- End With
- ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
- ActiveWorkbook.Close False
- Next
- With Cells(3, c + 1).Resize(r - 2)
- .Cells(1, 1).AutoFilter
- .Clear
- End With
- Application.ScreenUpdating = True
- End Sub
|
6楼
LOGO |
通过这个帖子，学到不少东西，谢谢小千版主的分享！
 |