拆分工具之六

rainniecc

老师，可否实现标题行是前面几列，然后按照行去拆分？

3190496160

rainniecc 发表于 2021-1-29 17:13
老师，可否实现标题行是前面几列，然后按照行去拆分？

拆分后你只需要前几列？你可以去下载另一个拆分工具

rainniecc

3190496160 发表于 2021-1-29 18:07
拆分后你只需要前几列？你可以去下载另一个拆分工具

我的意思是我们现有工具都是按列拆分，可以按行拆分吗？

3190496160

rainniecc 发表于 2021-2-2 08:33
我的意思是我们现有工具都是按列拆分，可以按行拆分吗？

这个得见到你的文件，要看具体的表格结构而定，
实现标题行是前面几列，然后按照行去拆分
这句话是什么意思？根本弄不明白的，标题是前几列，又要按行来拆分？？
实在不行，可以加q私聊

rainniecc

老师，我还想请教一下，一下代码要怎么改才可支持拆分之后的文件是xls的格式？

Sub chaifen()
    Set d = CreateObject("scripting.dictionary")
    Dim rg As Range
    On Error Resume Next
    Set rg = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    If rg Is Nothing Then MsgBox "您没有选择拆分依据列": Exit Sub
    Application.ScreenUpdating = False '关闭屏幕更新
    r = rg.Column
    p = InputBox("请输入标题行数", "标题行", "1")
    If p = "" Then MsgBox "您没有输入标题行数": Exit Sub
    pp = MsgBox("拆分为工作表选【是】，拆分为工作簿选【否】", vbYesNo)
    Set sh = ThisWorkbook.ActiveSheet
    ar = sh.[a1].CurrentRegion
    For i = Val(p) + 1 To UBound(ar)
        If Trim(ar(i, r)) <> "" Then
            d(Trim(ar(i, r))) = ""
        End If
    Next i
    If pp = vbNo Then GoTo 10
    Application.DisplayAlerts = False '关闭警告信息提示
    For Each sht In Worksheets '遍历一遍工作表，如果字典中存在则删除
        If d.exists(sht.Name) Then sht.Delete
    Next sht
    Application.DisplayAlerts = True
10:
    Dim rng As Range
    For Each k In d.keys
        If pp = vbYes Then
            sh.Copy after:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                 For i = Val(p) + 1 To UBound(ar)
                    If Trim(.Cells(i, r)) <> k Then
                        If rng Is Nothing Then
                            Set rng = .Rows(i)
                        Else
                            Set rng = Union(rng, .Rows(i))
                        End If
                    End If
                Next i
                rng.Delete
                For Each ss In .Shapes
                    ss.Delete
                Next ss
                .Name = k
            End With
            Set rng = Nothing
        ElseIf pp = vbNo Then
            sh.Copy
            With ActiveWorkbook.Worksheets(1)
                 For i = Val(p) + 1 To UBound(ar)
                    If Trim(.Cells(i, r)) <> k Then
                        If rng Is Nothing Then
                            Set rng = .Rows(i)
                        Else
                            Set rng = Union(rng, .Rows(i))
                        End If
                    End If
                Next i
                rng.Delete
                For Each ss In .Shapes
                    ss.Delete
                Next ss
                .Name = k
            End With
            Set rng = Nothing
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & k
            ActiveWorkbook.Close
        End If
    Next k
     Set d = Nothing
    Application.ScreenUpdating = True '恢复屏幕更新
    MsgBox "数据拆分完成！"
End Sub

xiaomils

谢谢楼主的分享！！

3190496160

rainniecc 发表于 2021-2-4 08:40
老师，我还想请教一下，一下代码要怎么改才可支持拆分之后的文件是xls的格式？

Sub chaifen()

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xls", xlexcel:=8

chzsh

拆分为多表多薄，拆分工作薄后，如果能把标题行下面没有数据的工作表再删除了，就更完美了

djp1018

rainniecc 发表于 2021-2-4 08:40
老师，我还想请教一下，一下代码要怎么改才可支持拆分之后的文件是xls的格式？

Sub chaifen()

将ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & k修改为 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & k& ".xls"

tangren9251

老师，请问拆分后的表格都保存在哪里了呢？