标签：Dim vba sht rng 表并 A1 Range End 改进版

Sub 插入()

On Error GoTo errHandler

Dim i As Long '按照标题插入空行
For i = 2 To Range("A1").CurrentRegion.Count - 1
Selection.End(xlDown).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(1, 0).Range("A1").Select
Next
errHandler:

Dim rng As Range '分割表格
Range("A1:M" & Range("B65536").End(xlUp).Row).AutoFilter Field:=2, Criteria1:="<>"
For Each rng In Range("A2:M" & Range("B65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Areas
Worksheets.Add after:=Worksheets(Worksheets.Count)
rng.Copy ActiveSheet.Range("A1")
Next rng
Range("A1:M" & Range("B65536").End(xlUp).Row).AutoFilter

On Error Resume Next
Dim k As Integer '复制表头
For k = 1 To Sheets.Count - 1
Sheets("汇总").Select
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet" & k).Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
ActiveSheet.Paste
Next

On Error Resume Next '
Dim FolderPath As String, FolderName As String, BN As String
Dim ReturnValue As Integer
Dim file_name$
Dim x As Integer, sht As Worksheet '表格改名
x = 1
For Each sht In Worksheets
If sht.Name <> "汇总" Then
sht.Name = Left(sht.Cells(2, 13).Value, Len(sht.Cells(2, 13).Value) - 5) '表格改名

sht.Copy '工作簿分割
file_name = ThisWorkbook.Path & "\" & sht.Name & ".xlsx"
ActiveWorkbook.SaveAs Filename:=file_name, FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
x = x + 1
End If
Next

End Sub

标签：Dim,vba,sht,rng,表并,A1,Range,End,改进版
来源： https://www.cnblogs.com/yukit/p/14107431.html

本站声明： 1. iCode9 技术分享网（下文简称本站）提供的所有内容，仅供技术学习、探讨和分享；
2. 关于本站的所有留言、评论、转载及引用，纯属内容发起人的个人观点，与本站观点和立场无关；
3. 关于本站的所有言论和文字，纯属内容发起人的个人观点，与本站观点和立场无关；
4. 本站文章均是网友提供，不完全保证技术分享内容的完整性、准确性、时效性、风险性和版权归属；如您发现该文章侵犯了您的权益，可联系我们第一时间进行删除；
5. 本站为非盈利性的个人网站，所有内容不会用来进行牟利，也不会利用任何形式的广告来间接获益，纯粹是为了广大技术爱好者提供技术内容和技术思想的分享性交流网站。