按班级导出的xls文件能保持原文件的列宽格式吗？敬请老师们赐教。

wtb8152

各位老师好！
请赐教，按班级导出的xls文件能保持原文件的行列宽格式吗？代码该怎样写？谢谢！。

microyip

另存为就行啦

wtb8152

谢谢microyip老师关注！
      不知怎么另存，我现在是想按班分别导出的，于我的理解另存是不是逐个手工进行的？这样无法按班存的。不知老师的另存是是怎样做，请赐教。谢谢！

lsc900707

wtb8152 发表于 2017-3-7 17:57
谢谢microyip老师关注！
      不知怎么另存，我现在是想按班分别导出的，于我的理解另存是不是逐个手工进 ...

先拆分到工作表再另存工作簿。
附件工作表有密码保护！

wtb8152

谢谢lsc900707老师指教！但是不知怎么做，请赐教，谢谢！

lsc900707

wtb8152 发表于 2017-3-7 19:22
谢谢lsc900707老师指教！但是不知怎么做，请赐教，谢谢！

用朱老师的灵活拆分工具第58楼的代码拆分吧

wtb8152

谢谢老师们的指点！谢谢！

lsc900707

将原代码稍作修改即可满足要求：
Sub 按班保存为工作簿()
    Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i&
    Set rng = Range("A1:x3")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Range("a1:x" & Range("a65536").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 4 To UBound(arr)
         If Not d.exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Cells(i, 1).Resize(1, 24)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, 24))
         End If
    Next
    k = d.keys
    t = d.items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[A1]: t(i).Copy .[A4]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\各班成绩文件\" & Mid(Range("f1"), 5, 7) & k(i) & "班成绩", FileFormat:=xlExcel8
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

lsc900707

wtb8152 发表于 2017-3-7 20:25
谢谢老师们的指点！谢谢！

将原代码修改一下就ok，详见9楼>>>>>>>