灵活拆分工具之三

3190496160 · 发表于 2020-5-2 11:52

1、可以浏览选择需要拆分的文件，选择文件中需要拆分的工作表
2、可以选择拆分为在原工作簿内的多个工作表，
3、可以选择拆分为多个独立工作簿文件
4、可以选择拆分为一个新的独立工作簿内的多个工作表
5、如果选择了拆分为多个独立工作簿，还可以选择次关键字，把每个独立工作簿内的工作表拆分根据次关键字拆分为多个工作表
6、可以保留原工作表的行高和列宽

拆分工具之三.rar (29.69 KB, 下载次数: 612)
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim arr As Variant
Dim i, s As Integer
Dim wb, wb1 As Workbook
Dim d As Object, d1 As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Dim sh As Worksheet
If ComboBox4.Text = "" Then
MsgBox "请选择要拆分的工作表"
Exit Sub
End If
If ComboBox3.Text <> "" And OptionButton2.Value = False Then
MsgBox "条件设置错误"
Exit Sub
End If
Set ww = ActiveWorkbook
Set ws = ww.Worksheets(ComboBox4.Text)
If ComboBox1.Text = "" Then
MsgBox "请输入标题行数"
Exit Sub
End If
If ComboBox2.Text = "" And ComboBox3.Text = "" Then
MsgBox "请输入拆分列"
Exit Sub
End If

If ComboBox2.Text <> "" And ComboBox3.Text = "" And OptionButton2.Value = True Then
wws = MsgBox("真的不需要次关键列？", vbYesNo)
If wws = vbNo Then
Exit Sub
End If
End If

If ComboBox3.Text <> "" And OptionButton2.Value = True Then
Set rng1 = ThisWorkbook.Worksheets("源").Columns(1).Find(ComboBox3.Text, , , xlWhole)
q1 = ThisWorkbook.Worksheets("源").Cells(rng1.Row, 2)
End If
Set rng = ThisWorkbook.Worksheets("源").Columns(1).Find(ComboBox2.Text, , , xlWhole)
q = ThisWorkbook.Worksheets("源").Cells(rng.Row, 2)
If OptionButton1.Value = False And OptionButton2.Value = False And OptionButton3.Value = False Then
MsgBox "请选择拆分类型"
Exit Sub
End If
If OptionButton1.Value = True Then
For Each sh In ww.Worksheets
      If sh.Name <> ComboBox4.Text Then sh.Delete
Next sh
End If
arr = ws.UsedRange
For i = ComboBox1.Text + 1 To UBound(arr)
If Len(arr(i, q)) Then
      If Not d.exists(arr(i, q)) Then
         Set d(arr(i, q)) = ws.Range("a" & i).Resize(1, UBound(arr, 2))
      Else
         Set d(arr(i, q)) = Union(d(arr(i, q)), ws.Range("a" & i).Resize(1, UBound(arr, 2)))
      End If
End If
Next i
If OptionButton3.Value = True Then
Application.SheetsInNewWorkbook = d.Count
Set wb1 = Workbooks.Add
i = 1
For Each k In d.keys
      wb1.Worksheets(i).Name = k
      i = i + 1
Next k
End If
x = d.keys
For k = 0 To UBound(x)
d1.RemoveAll
If OptionButton1.Value = True Then
      Worksheets.Add after:=ww.Worksheets(ww.Worksheets.Count)
            ww.ActiveSheet.Name = x(k)
         ws.Rows("1:" & ComboBox1.Text).Copy ww.ActiveSheet.[a1]
      d.items()(k).Copy ActiveSheet.Cells(ComboBox1.Text + 1, 1)
         For Each sh In ww.Worksheets
            For i = 1 To UBound(arr, 2)
                  If sh.Name <> ws.Name Then
                     Sheets(x(k)).Columns(i).ColumnWidth = ws.Columns(i).ColumnWidth
                  End If
            Next i
      Next sh
End If
If OptionButton2.Value = True And ComboBox3.Text = "" Then
Application.SheetsInNewWorkbook = 1
   Set wb = Workbooks.Add
With wb.Worksheets(1)
ws.Rows("1:" & ComboBox1.Text).Copy .[a1]
d.items()(k).Copy .Cells(ComboBox1.Text + 1, 1)
   For i = 1 To UBound(arr, 2)
      .Columns(i).ColumnWidth = ws.Columns(i).ColumnWidth
   Next i
   .Name = x(k)
wb.SaveAs Filename:=ThisWorkbook.Path & "\拆分文件\" & x(k) & ".xlsx"
wb.Close
End With
End If

If OptionButton2.Value = True And ComboBox3.Text <> "" Then
Application.SheetsInNewWorkbook = 1
   Set wb = Workbooks.Add
With wb.Worksheets(1)
ws.Rows("1:" & ComboBox1.Text).Copy .[a1]
d.items()(k).Copy .Cells(ComboBox1.Text + 1, 1)
   For i = 1 To UBound(arr, 2)
      .Columns(i).ColumnWidth = ws.Columns(i).ColumnWidth
   Next i
   .Name = x(k)
   brr = .UsedRange
For s = ComboBox1.Text + 1 To UBound(brr)
      If Not d1.exists(brr(s, q1)) Then
         Set d1(brr(s, q1)) = .Range("a" & s).Resize(1, UBound(brr, 2))
      Else
         Set d1(brr(s, q1)) = Union(d1(brr(s, q1)), .Range("a" & s).Resize(1, UBound(brr, 2)))
      End If
Next s
x1 = d1.keys
For s = 0 To UBound(x1)
      Set sh = Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
      sh.Name = x1(s)
      .Rows("1:" & ComboBox1.Text).Copy sh.[a1]
      d1.items()(s).Copy sh.Cells(ComboBox1.Text + 1, 1)
      For j = 1 To UBound(arr, 2)
         sh.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
      Next j
Next s

wb.SaveAs Filename:=ThisWorkbook.Path & "\拆分文件\" & x(k) & ".xlsx"
wb.Close
End With
End If
If OptionButton3.Value = True Then
ws.Rows("1:" & ComboBox1.Text).Copy wb1.Worksheets(x(k)).[a1]
d.items()(k).Copy wb1.Worksheets(x(k)).Cells(ComboBox1.Text + 1, 1)
      For i = 1 To UBound(arr, 2)
         wb1.Sheets(x(k)).Columns(i).ColumnWidth = ws.Columns(i).ColumnWidth
   Next i
End If
Next k
If OptionButton3.Value = True Then
wb1.SaveAs Filename:=ThisWorkbook.Path & "\拆分文件\" & "拆分数据表.xlsx"
wb1.Close False
End If
ww.Close True
MsgBox "OK!"
End
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
End
End Sub

Private Sub CommandButton3_Click() '浏览选择文件
Set d = CreateObject("scripting.dictionary")
filenames = Application.GetOpenFilename("所有文件 (*.*),", , "请选择文件")
If filenames = False Then GoTo 100
Set ww = Workbooks.Open(filenames)
For Each sh In ww.Worksheets
d(sh.Name) = ""
Next sh
Me.ComboBox4.List = d.keys
100:
End Sub

3190496160 · 发表于 2020-8-31 10:40

在功能上做了改进，修正了代码中的几个小错误

拆分工具之三 (20200926升级版）.rar (40.55 KB, 下载次数: 1003)

ycmzlg · 发表于 2020-5-2 16:59

sobili · 发表于 2020-5-3 11:37

大神，如果我想这个工具安装在自定义选项卡中，请问该如何操作？谢谢！

xj123321 · 发表于 2020-5-4 18:40

灵活拆分工具

danielwaiting · 发表于 2020-5-5 23:20

朱老师，可以实现一簿多表拆分为多簿多表，同时灵活选择每表的拆分条件和标题行数吗?

猪腰子 · 发表于 2020-5-6 09:54

很强大！赶紧实验一下

3190496160 · 发表于 2020-5-6 10:01

danielwaiting 发表于 2020-5-5 23:20
朱老师，可以实现一簿多表拆分为多簿多表，同时灵活选择每表的拆分条件和标题行数吗?

肯定是可以实现的，但是，这个就比较繁琐了，除非是量身定制

hanjianhanjian · 发表于 2020-5-17 18:25

多谢老师的分享。学习一下

axix · 发表于 2020-7-30 19:59

C:/Users/Administrator/Desktop/%E5%BE%AE%E4%BF%A1%E6%88%AA%E5%9B%BE_20200730195728.png下拉框中无法选择文件呢，是我下载的出问题了吗？有没有人试过

3190496160 · 发表于 2020-7-30 20:10

axix 发表于 2020-7-30 19:59
下拉框中无法选择文件呢，是我下载的出问题了吗？有没有人试过

你没有浏览选择文件，老兄

		自动登录	找回密码
密码			免费注册

[分享] 灵活拆分工具之三

评分

评分