zoukankan      html  css  js  c++  java
  • vba:改进版4按照空行分割工作表并保存为独立工作簿

    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

  • 相关阅读:
    慕课网 k8s环境搭建坑点
    这种yum源为阿里云
    linux yum安装jdk
    docker 常用命令
    docker部署
    docker windows安装 就是这么简单
    idea
    jrebel 破解失败 Unexpected response from server
    bladex flowable 表关系
    bladex 接口
  • 原文地址:https://www.cnblogs.com/yukit/p/14107431.html
Copyright © 2011-2022 走看看