根据关键字拆分工作表

chxw68

chqf 发表于 2014-6-30 18:17
chxw68 老师：
  是这样的，我想把这个宏作为一个加载宏，就是说制作一个自定义按钮，如果要拆分其他工作表 ...

对不起！我对加载宏不太熟悉，很少使用这个功能。

chqf

根据网上代码，做了个加载宏的，好像还可以用。还有一个问题：我想完善一下该代码，就是设置输入表头的行数，然后把超过1行的表头加载到新的工作簿，但如何引用表头好像有问题。代码如下：Sub auto_open()
Set myMenu = Application.CommandBars("worksheet menu bar")
Set Button = myMenu.Controls.Add(Type:=msoControlButton)
Button.Caption = "按管征单位拆分工作表"            '按钮上的文字，填写你需要的
Button.Style = msoButtonIconAndCaption
Button.FaceId = FaceId                  '按钮图标,数字比如8，系统存在的
Button.OnAction = "test"       '按钮执行的宏名，填写你自己编写的宏的宏名

End Sub
Sub test()
  Dim reg As Object
  Dim r%, i%, l%
  Dim arr
  Dim d As Object
  Dim str As String
  Dim x,y As Integer
  Dim bt
  Set d = CreateObject("scripting.dictionary")
  Set reg = CreateObject("vbscript.regexp")
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.SheetsInNewWorkbook = 1
  With Worksheets(1)
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    bt = .Range("a1").Resize(1, c)
  End With
  With reg
    .Global = True
    .Pattern = "外税|鼓楼|闽侯|福清|保税|音西|融城|晋安|仓山|连江|台江|永泰|闽清"
  End With
  With Worksheets(1)
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    l = Range("a1").End(xlToRight).Column
    arr = .Range("a2").Resize(r - 1, l)
  End With
  x = InputBox("请输入拆分关键字所在的列标：" & Chr(10) & Chr(10) & "例如在D列，则输入4", "友情提示：")
  y= InputBox("请输入表头占用的行数：" , "友情提示：")

For i = 1 To UBound(arr)
    If reg.test(arr(i, x)) Then
      Set mh = reg.Execute(arr(i, x))
      d(mh(0).Value) = d(mh(0).Value) & "+" & i
    End If
  Next
  'For Each ws In Worksheets
    'If ws.Name <> "Sheet1" Then
     ' ws.Delete
    'End If
  'Next
  For Each aa In d.Keys
    brr = Split(Mid(d(aa), 2), "+")
    ReDim crr(1 To UBound(brr) + 1, 1 To l)
    For i = 0 To UBound(brr)
      For j = 1 To l
        crr(i + 1, j) = arr(brr(i), j)
      Next
    Next
    Set wb = Workbooks.Add
    With wb
      With .Worksheets(1)
    ' With ActiveWorkbook
        .Range("a1").Resize(y, UBound(bt, 2)) = bt
        .Range("a"&y+1).Resize(UBound(crr), UBound(crr, 2)) = crr
        '.Sheets(1).UsedRange.Offset(m).Clear
        '.Sheet(1).[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
      End With
      .SaveAs Filename:=ThisWorkbook.Path & "\" & aa & ".xls"
     ' .SaveAs ThisWorkbook.Path & "\" & aa & ".xls"
      .Close
    End With
  Next
'    Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
'    With ws
'      .Name = aa
'      .Range("a1:c1") = Array("序号", "名称", "管征单位")
'      .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
'    End With
End Sub

代码好像有问题，麻烦chxw68老师看看。还有如果要引用原工作表的格式，又该怎么改呢？谢谢！！

chqf

.Range("a1").Resize(y, UBound(bt, 2)) = bt
这句好像执行不成功

jxndwxs

chxw68 发表于 2014-6-30 18:12
第一个问题解决了，第二个问题我就不知其解了。

老师您好：
我网上下载了一个“以关键词拆分工作薄”的文件。但拆分后，出现少了一行（少最后一行）

以关键词拆分工作薄.rar (45.86 KB, 下载次数: 9)

2014-7-2 10:11 上传

点击文件名下载附件

如：按性别拆分，分成“男”、“女”工作表，但“女”工作表中少一行。（本来有5人，拆分后只有4人了，少了原表中的最后一行）。如果原表是后一行性别是男，那么“男”工作表中也会少一行（也是少最后一行）。
请老师帮忙修改一下程序。谢谢。

chqf

按照你的需求，建议可以下载彭希仁老师的常用工具，挺好用的。

chxw68

修改好了。

chqf

chxw68 老师真是快枪手啊！能否也帮我解决一下问题？

jxndwxs

chxw68 发表于 2014-7-2 11:17
修改好了。

太好了，谢谢老师。

chxw68

chqf 发表于 2014-7-2 11:24
chxw68 老师真是快枪手啊！能否也帮我解决一下问题？

可以，只要我会。

chqf

chxw68 发表于 2014-7-2 11:17
修改好了。

如果能够改成窗体模式更好！