将一个工作表根据条件拆分成多个工作表保证行列宽

michaelaa

求助老师将一个工作表根据条件拆分成多个工作表保证行列宽，万分感谢！

liulang0808

1. Sub lkyy()
   
2. Dim ar, i%, wb As Workbook
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Sheets(1).Select
   
5. ar = Range("a3").CurrentRegion
   
6. For i = 4 To UBound(ar)
   
7.     d(ar(i, 3)) = ""
   
8. Next
   
9. For i = 0 To d.Count - 1
   
10.     Sheets(1).Copy after:=Sheets(Sheets.Count)
    
11.     With ActiveSheet
    
12.         .Name = d.keys()(i)
    
13.         Set Rng = Nothing
    
14.         For j = 4 To UBound(ar)
    
15.             If ar(j, 3) <> d.keys()(i) Then
    
16.                 If Rng Is Nothing Then
    
17.                     Set Rng = .Cells(j, 1)
    
18.                 Else
    
19.                     Set Rng = Union(Rng, .Cells(j, 1))
    
20.                 End If
    
21.             End If
    
22.         Next
    
23.         If Not Rng Is Nothing Then Rng.EntireRow.Delete
    
24.     End With
    
25. Next
    
26. Set d = Nothing
    
27. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。
保持格式不变，就是整表复制，然后删除相关项目

michaelaa

liulang0808 发表于 2019-8-15 07:50
附件内容供参考。。。。
保持格式不变，就是整表复制，然后删除相关项目

老师强大，谢谢！

everbest2015

貌似数据上了一万行    这个速度有点慢

everbest2015

Sub 按指定列拆分工作表并保留列宽行高()
    Dim sh As Worksheet, d As Object, ar, i&, s$, k, rg As Range
    If Sheets.Count > 1 Then
        Application.DisplayAlerts = False
            For Each sh In Sheets
                If sh.Name <> "固定区域" Then sh.Delete
            Next
        Application.DisplayAlerts = True
    End If
    Set sh = ThisWorkbook.Sheets(1)
    If sh.AutoFilterMode Then sh.AutoFilterMode = False
   sh.UsedRange = sh.UsedRange.Value
    ar = ActiveSheet.Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(ar)
        s = ar(i, 6)
        If s <> "" Then d(s) = ""
    Next
    If d.Count > 0 Then
        Application.ScreenUpdating = False: Application.DisplayAlerts = False
            For Each k In d.keys
                Sheets(1).Copy after:=Sheets(Sheets.Count)
                Set sh = ActiveSheet
                With sh
                    .Name = k
                    .UsedRange.AutoFilter field:=6, Criteria1:="<>" & k
                    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Delete
                    .UsedRange.AutoFilter
                End With
            Next
            Sheets(1).Select
        Application.ScreenUpdating = True: Application.DisplayAlerts = True
        MsgBox "亲,成功拆分出" + CStr(d.Count) & "个工作表", vbInformation, "提示"
    End If
End Sub

everbest2015

没用你的文件  用自己的文件重写了一个。前提是没有多行表头。没有合并单元格,经测试一万行数据用时5秒

大六九

Sub lkyy()
Set d = CreateObject("Scripting.Dictionary")
mrow = Cells(Rows.Count, 1).End(xlUp).Row
ar = Range("c4:c" & mrow)
For i = 1 To UBound(ar)
    d(ar(i, 1)) = ""
Next i
For i = 0 To d.Count - 1
    Sheets(1).Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = d.keys()(i)
        For j = UBound(ar) To 1 Step -1
            If ar(j, 1) <> d.keys()(i) Then
               .Cells(j + 3, 1).EntireRow.Delete
            End If
        Next j
    End With
Next i
MsgBox "如有不明白或者没有解决，可以vX联系linlietao0487"
End Sub

ayjxa

liulang0808 发表于 2019-8-15 07:50
附件内容供参考。。。。
保持格式不变，就是整表复制，然后删除相关项目

能帮忙看看这附件的表格可否按G列拆分，表格上下描颜色的内容保留，格式也保持一样，有把拆分后的样式做在另外两个SHEET里。非常感谢

销魂白米饭

liulang0808 发表于 2019-8-15 07:48

按照老师的方法，怎另存为工作簿呢