EXCEl按某一列拆分工作表到工作薄，并保持原来格式

WXY075675

按D列拆分，并保持原有格式

shenjianrong163

用这个工具：
http://club.excelhome.net/thread-1533115-1-1.html

qazwsxedc123!

做好了，麻烦给2朵花

3190496160

下载就能用
Excel 灵活拆分工具之三-ExcelVBA程序开发-ExcelHome技术论坛 - http://club.excelhome.net/thread-1535151-1-1.html

donghui2363

我写的速度比较慢，保留格式再加上序号，拆分这几个需要将近二十秒，你试试
Sub 拷贝()
    Dim wk As Workbook
    Dim sht As Worksheet, sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    Set sht = Sheets("那丽镇")
    arr = sht.UsedRange
    For i = 5 To UBound(arr)
        d(arr(i, 4)) = ""
    Next i
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For Each dk In d.keys
        For i = 5 To UBound(arr)
            If arr(i, 4) = dk Then
                k = k + 1
                For j = 1 To UBound(arr, 2)
                    brr(k, j) = arr(i, j)
                Next j
            End If
        Next i
        Set wk = Workbooks.Add
        wk.Sheets(1).Name = sht.Name & "-" & dk
        Set sh = wk.Sheets(1)
        sht.Rows("1:" & k).Copy sh.Range("a1")
        sht.Columns("a:q").Copy sh.Range("a1")
        sh.UsedRange.Offset(4).ClearContents
        sh.UsedRange.Offset(k + 4).Clear
        sh.Range("a5").Resize(k, UBound(brr, 2)) = brr
        ReDim crr(1 To k, 1 To 1)
        For xh = 1 To k
            crr(xh, 1) = xh
        Next xh
        sh.Range("a5").Resize(k, 1) = crr
        wk.SaveAs ThisWorkbook.Path & "\" & dk & ".xlsx"
        wk.Close False
        k = 0
    Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "拆分完毕"
End Sub

WXY075675

qazwsxedc123! 发表于 2020-5-31 14:13
做好了，麻烦给2朵花

是拆分了，但是格式已经变了

lwwy1981

WXY075675 发表于 2020-6-23 20:21
是拆分了，但是格式已经变了

格式保持原样

WXY075675

lwwy1981 发表于 2020-6-23 21:20
格式保持原样

高手，再帮我设置个表好吗？谢谢了！！！！！

WXY075675

lwwy1981 发表于 2020-6-23 21:20
格式保持原样

有没有能提示选列拆分的，有时候会时拆分其他列的

lwwy1981

WXY075675 发表于 2020-6-23 21:25
高手，再帮我设置个表好吗？谢谢了！！！！！

什么样的表