关于批量生成工作表复制格式的问题

okzmz001

Sub lqxs()
    Dim col%, cc&, Arr, d, k, i&, j&, aa, bt As Range
    Dim Sht As Worksheet, Sht1 As Worksheet, c%, x$, y$
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Sht1 = ActiveSheet
    For Each Sht In Sheets
        If Sht.Name <> Sht1.Name Then Sht.Delete
    Next Sht
    col = 5
        On Error Resume Next
    Arr = [a1].CurrentRegion

    Set bt = Sht1.[a1].Resize(3, UBound(Arr, 1))
    For i = 4 To UBound(Arr)
        x = Arr(i, col)
        d(x) = d(x) & i & ","
    Next
    k = d.keys: t = d.items
    For i = 0 To UBound(k)
        Sheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = k(i): cc = 1
            bt.Copy .Cells(1, cc)
            t(i) = Left(t(i), Len(t(i)) - 1)
            If InStr(t(i), ",") Then
                aa = Split(t(i), ",")
                For j = 0 To UBound(aa)
                    .Cells(j + 4, cc).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, aa(j), 0)
                Next
            Else
                .Cells(4, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, t(i), 0)
            End If
            .[a4].Select
        End With
    Next
    Sht1.Activate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub


以上是我的代码，批量生成没有问题了，但是就是格式全变了，比如表格的宽度、单元格的属性、边框也没有了，请高手指点，谢谢已上传附件，弄了半天，格式还是不对，需要生成的表格与原来的一样，谢谢

iwangyi

没有格式才对，有格式那才奇怪了,以上代码只数据处理；
楼主说的格式代码
Range().Height
Range().Width
Range().Borders
一个也没有
怎么会有格式呢