同时对多个表格按某一列拆分为不同的工作簿

陆地鱼仙人掌

如题
现在一个工作薄里面呢有三个sheet：汇总，主任，营销员。现在需要根据地区这一列，拆分为不同的工作薄，每个工作薄指含有一个地区的内容。原始文件和拆分后想要的效果见附件，有没有大神帮忙？

陆地鱼仙人掌

有没有大神帮忙？

lvexcel_0210

自动筛选地区，然后F5定位，只显示可见单元格，然后复制粘贴吧

abc123281

按地区拆分abc123.rar (23.51 KB, 下载次数: 260)

2018-5-6 21:36 上传

点击文件名下载附件

陆地鱼仙人掌

abc123281 发表于 2018-5-6 21:36

真的可行，感谢！

陆地鱼仙人掌

abc123281 发表于 2018-5-6 21:36

你好，今天试另一个工作薄，结构差不多。发现提示拆分完成了，但是文件夹里没有拆出的文件，要怎么处理呢？感谢！

陆地鱼仙人掌

abc123281 发表于 2018-5-6 21:36

你好，今天试另一个工作薄，结构差不多。发现提示拆分完成了，但是文件夹里没有拆出的文件，要怎么处理呢？感谢！

lsc900707

Sub test()
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    Set wb1 = ThisWorkbook
    For Each Sht In Sheets
        arA = Sht.[a1].CurrentRegion
        For i = 1 To UBound(arA, 2)
            If arA(1, i) = "地区" Then j = i: Exit For
        Next
        For i = 3 To UBound(arA)
            d(arA(i, j)) = ""
        Next
    Next
    k = d.keys: t = d.items
    For i = 0 To UBound(k)
        Application.SheetsInNewWorkbook = wb1.Sheets.Count
        Workbooks.Add
        Set wb = ActiveWorkbook
        With wb
            For x = 1 To wb1.Sheets.Count
                arA = wb1.Sheets(x).[a1].CurrentRegion
                m = 2
                For j = 1 To UBound(arA, 2)
                    If arA(1, j) = "地区" Then jj = j: Exit For
                Next
                For j = 3 To UBound(arA)
                    If arA(j, jj) = k(i) Then
                        m = m + 1
                        wb1.Sheets(x).Cells(j, 1).Resize(1, UBound(arA, 2)).Copy .Sheets(x).Cells(m, 1)
                        wb1.Sheets(x).Cells(1, 1).Resize(2, UBound(arA, 2)).Copy .Sheets(x).[a1]
                    End If
                Next
                .Sheets(x).Name = wb1.Sheets(x).Name
                .Sheets(x).[a2].CurrentRegion.Borders.LineStyle = 1
                For y = 1 To UBound(arA, 2)
                   .Sheets(x).Columns(y).ColumnWidth = wb1.Sheets(x).Columns(y).ColumnWidth
                Next
            Next
        End With
        wb.SaveAs ThisWorkbook.Path & "\" & Split(wb1.Name, ".")(0) & "(" & k(i) & ")" & ".xlsx"
        wb.Close
    Next
    MsgBox "OK"
    Application.ScreenUpdating = True
End Sub

lsc900707

附件回传供测试参考：

abc123281

上传附件来看