分类： 作品

Sub 将表按列拆分成多表并另存()

    Dim sht, sht0, sht1 As Worksheet
    Dim Msg, j, k, L, n As Integer                        '定义整形变量
    Dim iRow, iColumn As Integer                         '定义存放行和列的数量
    Dim BiaoMing, ShaiXuan, objFD As String
    Dim sCol
    
    
    Set sht0 = ActiveSheet
    iRow = sht0.Range("a65536").End(xlUp).Row                    '获取行数
    iColumn = sht0.Range("XFD1").End(xlToLeft).Column            '获取列数
    
    '询问用户是否确认进行操作
    Msg = MsgBox("除了当前选中的表，其它表都将被删除，请确定是否继续", 17, "<<<<只剩选中表确认>>>>")
    'MsgBox msg
    If Msg = 2 Then
        Exit Sub
    End If
    
    
    '删除激活表以外的表
    Application.DisplayAlerts = False
    If Sheets.Count > 1 Then
        For Each sht1 In Sheets
            If sht1.Name <> sht0.Name Then
                sht1.Delete
            End If
        Next
    End If
    Application.DisplayAlerts = True
          
    
    '通过自定义函数获取用户选择的列
    Msg = "请问您要按那列拆分表？" & Chr(13) & "可以输入A～XFD 或者 直接输入数字"
    Tit = "表格列选择"
    Typ = 1 + 2                                                       '0=公式，1=数字，2=文本，4=逻辑值，8=单元格引用，16=错误值，64=数值数组
    L = Get_Column_Num(Msg, Tit, Typ)                                   '调用自定义函数转换后的列数
     
    
    '拆分表
    For j = 2 To iRow
        n = 0
        If sht0.Cells(j, L) = "" Then
            BiaoMing = "空白"
        Else
            BiaoMing = sht0.Cells(j, L)
        End If
        
        For Each sht In Sheets
           If sht.Name = BiaoMing Then
               n = 1
           End If
        Next
        
        If n = 0 Then
            Sheets.Add after:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = BiaoMing
        End If

    Next
    
    '拷贝数据
    For k = 2 To Sheets.Count
    
        If Sheets(k).Name = "空白" Then
            ShaiXuan = "="
        Else
            ShaiXuan = Sheets(k).Name
        End If
        
        sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).AutoFilter Field:=L, Criteria1:=ShaiXuan
        sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).Copy Sheets(k).Range("a1")
    Next
    
    '让表格处于筛选状态，并选中数据表
    sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).AutoFilter
    sht0.Range(sht0.Cells(1, 1), sht0.Cells(iRow, iColumn)).AutoFilter
    sht0.Select
    
    Msg = 0
    Msg = MsgBox("拆分成功！" & Chr(13) & "请确认是否需要将拆分出来的多表另存为单个文件" & Chr(13) & "存放目录若有相同名字的表将被替换", 65, "<<<<拆分出来的多表另存确认>>>>")
    'MsgBox msg
    If Msg = 2 Then
        Exit Sub
    End If

    '人工选取存放的路径
    
    Title = "请选择分表后存放的目录"
    '调用自定义函数获取路径地址
    objFD = GetFileDialogFolderPicker(Title)
    '若用户在弹出的选择窗口上点了取消则退出
    If objFD = "" Then
        Exit Sub
    End If
    
    '调用表格另存为的方法
    Call Excel_Auto_SaveAs(objFD)
    
    MsgBox "处理完成", , "完成"
    
End Sub

'弹出对话框让用户选择列
Function Get_Column_Num(ByVal Msg As String, ByVal Tit As String, ByVal Typ As Integer) As Long
    '下面的代码弹出提示框让用户选择要按那列进行拆分表
    sCol = Application.InputBox(Msg, Tit, Type:=Typ) '0=公式，1=数字，2=文本，4=逻辑值，8=单元格引用，16=错误值，64=数值数组
     
    'MsgBox VarType(sCol)

    '用[VarType 数据类型]判断用户的输入类型
    If VarType(sCol) = 11 Then                  '点击了取消则返回0
        Get_Column_Num = 0
    ElseIf VarType(sCol) = 8 Then               '输入了文本类型就进行转换成数字
        Get_Column_Num = Range(sCol & 1).Column
    ElseIf VarType(sCol) = 5 Then               '输入的是数字就直接取数字
        Get_Column_Num = sCol
    End If

End Function

'获取用户选择的路径函数
Function GetFileDialogFolderPicker(ByVal Tit As String)
    '人工选取存放的路径
    Set objFD = Application.FileDialog(msoFileDialogFolderPicker)
    With objFD
        .Title = Tit
        If .Show = -1 Then
        ' 如果单击了确定按钮，则将选取的路径保存在变量中
        sPath = .SelectedItems(1) & "\"
        'MsgBox sPath
        End If
    End With
        GetFileDialogFolderPicker = sPath
        
        'MsoFileDialogType           可为下述常量之一:
        'msoFileDialogFilePicker     允许用户选择文件
        'msoFileDialogFolderPicker   允许用户选择文件夹
        'msoFileDialogOpen           允许用户打开文件
        'msoFileDialogSaveAs         允许用户保存文件
End Function

'实现表格另存为并将同名表替换
Sub Excel_Auto_SaveAs(objFD As String)
    Dim sht As Worksheet
    Application.ScreenUpdating = False      '屏幕更新事件关闭
    Application.DisplayAlerts = False       '警告事件关闭
    
    'On Error Resume Next                    '出现错误执行下步代码，比如保存的位置有相同文件名的表
    For Each sht In Sheets
        If Dir(objFD & sht.Name & ".xlsx") = sht.Name & ".xlsx" Then    '判断若表格已经存在就先删除表格
            Kill objFD & sht.Name & ".xlsx"                             '删除表格
        End If
        sht.Copy
        ActiveWorkbook.SaveAs Filename:=objFD & sht.Name & ".xlsx"
        ActiveWorkbook.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub