根据关键字拆分工作表

chqf

chxw68 老师，抽空帮我看看？

chqf

chxw68老师，能否帮我完善一下？

chqf

这帖子沉得太快了！！！

chqf

chxw68 老师，能否帮忙解决一个问题：怎样保留新拆分后工作表的格式？

chxw68

chqf 发表于 2014-7-17 17:44
chxw68 老师，能否帮忙解决一个问题：怎样保留新拆分后工作表的格式？

你要保留哪些格式？

chqf

比如原表的字体、表头格式等。这是我根据您的代码凑的，您帮我看看？
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
  Dim att, btt As Range
  Set d = CreateObject("scripting.dictionary")
  Set reg = CreateObject("vbscript.regexp")
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.SheetsInNewWorkbook = 1
   x = InputBox("请输入拆分关键字所在的列标：" & Chr(10) & Chr(10) & "例如在D列，则输入4", "友情提示：")
   y = InputBox("请输入表头占用的行数：", "友情提示：")

  
  With Worksheets(1)
    c = .Cells(y + 1, .Columns.Count).End(xlToLeft).Column
    bt = .Range("a1").Resize(y, 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("a" & y + 1).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 att = Range("a1").Resize(y, UBound(bt, 2))
   ' Set btt = Range("a" & y + 1).Resize(UBound(crr), UBound(crr, 2))
    Set wb = Workbooks.Add
  
    With wb
      With .Worksheets(1)
    ' With ActiveWorkbook
      ' .Range("a1").Resize(1, UBound(bt, 2)) = bt
       ' .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
        '.Sheets(1).UsedRange.Offset(m).Clear
        '.Sheet(1).[a1].Resize(UBound(crr), UBound(crr, 2)) = crr
      'att.Copy
         
    .Range("a1").Resize(y, UBound(bt, 2)) = bt
       ' .Range("a" & y + 1).Resize(UBound(crr), UBound(crr, 2)) = crr
         .Range("a1").PasteSpecial Paste:=xlPasteFormats
        'btt.Copy
        .UsedRange.EntireColumn.AutoFit
         .UsedRange.EntireRow.AutoFit
      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

chqf

目前可以实现复制表头了。

chqf

又沉了，自己顶。

chxw68

1. Sub test()
   
2.   Dim reg As Object
   
3.   Dim r%, i%, l%
   
4.   Dim arr
   
5.   Dim d As Object
   
6.   Dim str As String
   
7.   Dim x As Integer
   
8.   Dim bt
   
9.   Dim lk(), hg(1 To 2)
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   Set reg = CreateObject("vbscript.regexp")
    
12.   
    
13.   Application.ScreenUpdating = False
    
14.   Application.DisplayAlerts = False
    
15.   Application.SheetsInNewWorkbook = 1
    
16.   
    
17.   With reg
    
18.     .Global = True
    
19.     .Pattern = "外税|鼓楼|闽侯|福清|保税|音西|融城|晋安|仓山|连江|台江|永泰|闽清"
    
20.   End With
    
21.   
    
22.   With Worksheets("aa")
    
23.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
24.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
25.     bt = .Range("a1").Resize(1, c)
    
26.     arr = .Range("a2").Resize(r - 1, c)
    
27.     ReDim lk(1 To c)
    
28.     For j = 1 To c
    
29.       lk(j) = .Columns(j).ColumnWidth
    
30.     Next
    
31.     hg(1) = .Rows(1).RowHeight
    
32.     hg(2) = .Rows(2).RowHeight
    
33.   End With
    
34.   
    
35.   x = InputBox("请输入拆分关键字所在的列标：" & Chr(10) & Chr(10) & "例如在D列，则输入4", "友情提示：")
    
36.   
    
37.   For i = 1 To UBound(arr)
    
38.     If reg.test(arr(i, x)) Then
    
39.       Set mh = reg.Execute(arr(i, x))
    
40.       d(mh(0).Value) = d(mh(0).Value) & "+" & i
    
41.     End If
    
42.   Next
    
43.   tt = d.Items
    
44.   For Each aa In d.Keys
    
45.     brr = Split(Mid(d(aa), 2), "+")
    
46.     ReDim crr(1 To UBound(brr) + 1, 1 To UBound(arr, 2))
    
47.     For i = 0 To UBound(brr)
    
48.       For j = 1 To UBound(arr, 2)
    
49.         crr(i + 1, j) = arr(brr(i), j)
    
50.       Next
    
51.     Next
    
52.     Set wb = Workbooks.Add
    
53.     With wb
    
54.       With .Worksheets(1)
    
55.         .Range("a1").Resize(1, UBound(bt, 2)) = bt
    
56.         .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
57.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
58.         .Range("a1:f" & r).Borders.LineStyle = xlContinuous
    
59.         For j = 1 To UBound(lk)
    
60.           .Columns(j).ColumnWidth = lk(j)
    
61.         Next
    
62.         .Rows(1).RowHeight = hg(1)
    
63.         .Rows(2 & ":" & r).RowHeight = hg(2)
    
64.         .Range("a1:f1").Font.Bold = True
    
65.         With .Range("a1:f" & r)
    
66.           .Font.Name = "宋体"
    
67.           .Font.Size = 10
    
68.         End With
    
69.         
    
70.       End With
    
71.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa & ".xls"
    
72.       .Close
    
73.     End With
    
74.   Next
    
75. End Sub
    

复制代码

chxw68

修改好了。