根据条件筛选后拆成多个表格

ccyinger

请教各位大神，
如何将文件中进行“省份”筛选后，
将不同省份的所有内容生成一个新*xlsx，文件命名为该省份
附件中的代码是我网上找的拿来套用，但是他筛选后只提取一列数据，而我想要的是全部的内容，包括表头和格式以及公式,各位大神能否帮忙看下能否用VBA代码实现，
非常感谢！

f8b1987

另存为一个表，删除非省份的，再拆分就行

ccyinger

f8b1987 发表于 2021-12-9 15:06
另存为一个表，删除非省份的，再拆分就行

你好，我是想要建个宏或者vba代码，可以一键执行拆分，因为平时的表格数据太大了，如果一个个拆分工作量太大

nevercool

按省份拆分

ccyinger

nevercool 发表于 2021-12-9 16:37
按省份拆分

你的附件里面没看到代码

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Dim d As Object
Dim sh As Worksheet
Dim rng As Range
Set sh = ThisWorkbook.ActiveSheet
Set d = CreateObject("scripting.dictionary")
With sh
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:az" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        d(Trim(ar(i, 4))) = ""
    End If
Next i
For Each k In d.keys
    sh.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        For i = 2 To UBound(ar)
            If Trim(.Cells(i, 4)) <> k Then
                If rng Is Nothing Then
                    Set rng = .Rows(i)
                Else
                    Set rng = Union(rng, .Rows(i))
                End If
            End If
        Next i
        For Each sp In .Shapes
            sp.Delete
        Next sp
    End With
    If Not rng Is Nothing Then rng.Delete
    Set rng = Nothing
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

需拆分的文件.rar (35.62 KB, 下载次数: 9)

2021-12-9 17:30 上传

点击文件名下载附件

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Dim d As Object
Dim sh As Worksheet
Dim rng As Range
Set sh = ThisWorkbook.ActiveSheet
Set d = CreateObject("scripting.dictionary")
With sh
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:az" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        d(Trim(ar(i, 4))) = ""
    End If
Next i
For Each k In d.keys
    sh.Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        For i = 2 To UBound(ar)
            If Trim(.Cells(i, 4)) <> k Then
                If rng Is Nothing Then
                    Set rng = .Rows(i)
                Else
                    Set rng = Union(rng, .Rows(i))
                End If
            End If
        Next i
        For Each sp In .Shapes
            sp.Delete
        Next sp
    End With
    If Not rng Is Nothing Then rng.Delete
    Set rng = Nothing
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

mjm04

开通WPS会员，用 表格拆分 选项 里的按内容拆分

nevercool

ccyinger 发表于 2021-12-9 16:52
你的附件里面没看到代码

不是用vba写的，但也基于vb,代码思路供你参考：
Dim Book As New XLS.Book
Dim t As Table = Tables("需拆分的文件")
Dim sfs As List(of String) = DataTables("需拆分的文件").GetValues("省份")
For Each sf As String In sfs
    Dim Sheet As XLS.Sheet = Book.Sheets.Add(sf)
    For i As Integer = 0 To t.Cols.Count -1
        Sheet(0, i).Value = t.Cols(i).Name
    Next
    t.Filter = "省份 = '" & sf & "'"
    For r As Integer = 0 To t.Rows.Count - 1
        For n As Integer = 0 To t.Cols.Count -1
            Sheet(r +1, n).Value = t.rows(r)(n)
        Next
    Next
Next
Book.Save("d:\excel\按省份拆分.xls")