|
Sub 按照每个工作簿多少行拆分()
Dim wbk As Workbook
Application.ScreenUpdating = True
Dim arr, d As Object, sh As Worksheet
Set d = CreateObject("scripting.dictionary")
Filename = Application.GetOpenFilename("Excel 文件 (*.xls*),*.xls*", , "请选择要分表的工作表所在的位置!", , 0)
If Filename = False Then Exit Sub
Set sjwk = Workbooks.Open(Filename) '要分表的数据所在表
shname = sjwk.ActiveSheet.Name
Set rng1 = Application.InputBox("请选择工作表准备参加拆分的完整区域,不要选择整列整行,只选择绝对区域", "选取提示", , , , , , 8)
If rng1 Is Nothing Then MsgBox "您没有选择要保存的列区域": Exit Sub
arr = sjwk.ActiveSheet.Range(rng1.Address)
Y = UBound(arr, 2)
hh = UBound(arr, 1)
BH = Application.InputBox("请输入标题的行数【如标题为1行,则写1,2行则写2】:", "提示", , , , , , 1)
MN = Application.InputBox("请输入每个工作簿行数【如300行,则写300】:", "提示", , , , , , 1)
xz = MsgBox("拆分为多个工作簿选【是】,拆分为多个工作表选【否】", vbYesNo)
If xz = vbYes Then
With sjwk.ActiveSheet
For i = 1 To .Cells(.Rows.Count, 1).End(3).Row Step MN
K = K + 1
Set wbk = Workbooks.Add
If BH > 0 Then
.Rows("1:" & BH).Copy wbk.Sheets(1).Range("a1") '复制标题
.Rows(i).Resize(MN).Copy wbk.Sheets(1).Cells(BH + 1, 1)
Else
.Rows(i).Resize(MN).Copy wbk.Sheets(1).Cells(BH + 1, 1)
End If
wbk.Close True, sjwk.Path & "\" & wbk.Sheets(1).Cells(BH + 1, 1).Value & K
Next
End With
Set wbk = Nothing
Else: xz = vbNo
With sjwk.ActiveSheet
For i = 1 To .Cells(.Rows.Count, 1).End(3).Row Step MN
K = K + 1
Set sh = sjwk.Sheets.Add(, after:=ActiveSheet)
If BH > 0 Then
.Rows("1:" & BH).Copy sh.Range("a1") '复制标题
.Rows(i).Resize(MN).Copy sh.Cells(BH + 1, 1)
sh.Name = sh.Cells(BH + 1, 1).Value & K
Else
.Rows(i).Resize(MN).Copy sh.Cells(BH + 1, 1)
sh.Name = sh.Cells(BH + 1, 1).Value & K
End If
Next
End With
End If
Application.ScreenUpdating = True
End Sub
按照每个工作簿多少行拆分.rar
(15.42 KB, 下载次数: 42)
|
评分
-
1
查看全部评分
-
|