VBA对数据表进行拆分(分列)及保存

同事经常遇到问题,这个按照部门进行分类,还要进行保存,好麻烦,每次手动都要半天,还可能出错。所以针对这个问题,用VBA写了个分列和保存的宏。

 

一、使用前说明:

1.要分列的表列中间不要出现空内容,比如要分第2列部门,里面有A部门,B部门,还有个空内容的,可能导致计算行数不准。

2.分列后的表序号功能还未完善,分列后还要手动拉一下序号

3.其他bug还在完善中

 

二、表格拆分(分列)和保存效果图

1.这是要进行操作的表

2.运行分列的宏

以第二列——部门进行分列

标题在第3列,写个3

3.运行结束后效果:

分列完毕!(序号功能未完善,手动拉一下)

运行保存的宏代码实现保存

4.运行保存的宏,效果如下

 

操作结束

三、表格拆分(分列)及保存文件宏代码

 

Option Explicit

Sub 分列()
    
    
    '工作表根据各项目类别进行分列

    Dim rowNum As Integer, colNum As Integer, sh As Worksheet

    
    Dim k As Boolean, i As Integer, j As Integer
    Dim inputCol As Integer, inputRow As Integer
    
    k = True
    
    '根据用户选择,对哪一列的内容进行分列。
    inputCol = InputBox("要拆分第几列的数据?")
    
    '因为每个表的标题行数不一样,手动让用户输入
    inputRow = InputBox("标题行在第几行?")
    
        
    'rowNum:获取sheets(1)的总行数
    'colNum:获取sheets(1)的总列数
    rowNum = ThisWorkbook.Worksheets(1).Cells(inputRow, 1).End(xlDown).row
    colNum = ThisWorkbook.Worksheets(1).Cells(1, inputRow).End(xlToRight).Column
    
    
    '根据要分的列,遍历用户输入的行数+1到总行数,确定要新建多少个sheets
    For i = inputRow + 1 To rowNum
        For Each sh In Sheets
        
            '判断单元格内容,如果表名已存在,就不干啥
            If sh.Name = Sheets(1).Cells(i, inputCol) Then
               k = False
               Exit For
            End If
        Next
        If k = True Then
            '判断单元格内容,如果表名不存在,就新建一张表,命名为这个单元格的内容
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = Sheets(1).Cells(i, inputCol)
        End If
        k = True
    Next
    
    '新建完sheets后,筛选sheets(1)表格,复制到每张表里
    For i = 2 To Sheets.Count
        '从sheets(2)开始,先清除表格内容,防止存在其他内容,并设置为文本格式,防止身份证等长数字复制出错
        Sheets(i).Cells.ClearContents
        Sheets(i).Cells.NumberFormat = "@"
        
        '根据用户输入的函数进行筛选
        Sheets(1).Select
        Rows(inputRow).Select
        Selection.AutoFilter
        '根据输入要分列的列数,匹配各sheets名称,对应名称复制过去
        Cells(inputRow, 1).AutoFilter Field:=inputCol, Criteria1:=Sheets(i).Name
        Sheets(1).Range(Cells(1, 1), Cells(rowNum, colNum)).Copy Sheets(i).Range("A1")
        Sheets(1).Cells(inputRow, 1).AutoFilter

    Next
    
    '让每个生成完毕的表格的列宽度和sheets(1)的宽度一致
    For i = 2 To Worksheets.Count
        For j = 1 To colNum
            Sheets(i).Columns(j).ColumnWidth = Sheets(1).Columns(j).ColumnWidth
        Next j
    Next i
    
    '全部完成后,返回到sheets(1)
    Sheets(1).Select
    
End Sub

 

以下是保存文件的宏代码

Sub 保存()
    
    '暂停屏幕滚动
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim i As Integer
    Dim path As String
    
    '获取当前文件的路径,因为要保存的表格也放在这个路径下面
    path = ThisWorkbook.path
  
    '文件夹名称以当前时间命名
    filefile = Format(Now, "YYYY年MM月DD日HH时MM分SS秒保存")
    
    '判断文件名是否存在,不存在就新建
    If Dir(path & "\" & filefile, vbDirectory) <> "" Then
        MsgBox "文件夹存在"
    Else
        MkDir (path & "\" & filefile)
        '判断表格是否只有1张sheets,就不保存
        If Sheets.Count = 1 Then
            MsgBox ("没有需要保存的表")
        Else
            For i = 2 To Sheets.Count
                Sheets(i).Copy
                '从第2张sheet开始,已sheet名称作为文件名进行保存
                ActiveWorkbook.SaveAs Filename:=path & "\" & filefile & "\" & Sheets(1).Name
                ActiveWorkbook.Close
            Next
        End If
    End If
    
    '运行完毕恢复屏幕滚动
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

©️2020 CSDN 皮肤主题: 书香水墨 设计师:CSDN官方博客 返回首页