工作表已会拆分，求拆分后的格式一致

lmlovely

各位大侠，小女子在工作表的拆分上已照样画葫芦会了皮毛，但拆分好了之后发现数据的一些格式发生了变化，边框没有设置，这个问题如何在代码中修改？谢谢各位，复制代码如下：请赐教！
Sub fj()
    Dim d As Object, i&, k&, r&, ar, arr
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
     For Each sh In Sheets
         If sh.Name <> "sheet1" Then sh.Delete
     Next
     With Sheets("sheet1")
        ar = .Range("a2:p" & .[a65536].End(3).Row)
        ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
    End With
    brr = Array("组别", "序号", "1起", "1止", "2起", "2止", "地点")
    For i = 1 To UBound(ar)
        d(ar(i, 1)) = ""
    Next
   
    m = d.keys
    For n = 0 To d.Count - 1
        k = 0
        With Worksheets.Add(after:=Sheets(Sheets.Count))
            .Name = m(n)
            For i = 1 To UBound(ar)
                If ar(i, 1) = m(n) Then
                    k = k + 1
                    For r = 1 To UBound(ar, 2)
                        arr(k, r) = ar(i, r)
                    Next
                End If
            Next
            .[a1].Resize(1, 8) = brr
            .[a2].Resize(k, UBound(ar, 2)) = arr
        End With
    Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     Set d = Nothing
End Sub

dsmch

1. Sub fj()
   
2.     On Error Resume Next
   
3.     Dim d As Object, i&, k&, r&,  arr, sht As Worksheet
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set sht = Sheets("sheet1")
   
8.      For Each sh In Sheets
   
9.          If sh.Name <> sht.Name Then sh.Delete
   
10.      Next
    
11.     sht.Activate
    
12.     [a1].CurrentRegion.Sort [a2], Header:=xlGuess
    
13.     arr = Range("a1:g" & Range("a65536").End(xlUp).Row + 1)
    
14.     x = 3
    
15.     For i = 4 To UBound(arr)
    
16.         If arr(i, 1) <> arr(i - 1, 1) Then
    
17.             d(arr(x, 1)) = x & "," & i - 1: x = i
    
18.         End If
    
19.     Next
    
20.     a = d.keys: b = d.items
    
21.     For n = 0 To d.Count - 1
    
22.         If Sheets("" & a(n)) Is Nothing Then
    
23.             sht.Copy after:=Sheets(Sheets.Count)
    
24.             With ActiveSheet
    
25.                 .Name = a(n)
    
26.                 .[a1].CurrentRegion.Offset(1, 0).Clear
    
27.                 x = Split(b(n), ",")
    
28.                 sht.Range("a" & x(0) & ":g" & x(1)).Copy .[a2]
    
29.             End With
    
30.         End If
    
31.     Next
    
32.     sht.Activate
    
33.     Application.DisplayAlerts = True
    
34.     Application.ScreenUpdating = True
    
35. End Sub

复制代码

lmlovely

dsmch 发表于 2015-5-21 06:24

谢谢，兄弟！

LMY123

拆分工作表并保留格式

darlingxx

认真学习中，