将筛选结果另存为新的工作薄，麻烦老师看下，非常感谢

jamesz01

老师们，求助：在A列筛选后，将筛选结果和表头在当前路径另存为一个新的工作薄，并且保留原本的公式，新工作薄的名称根据筛选结果命名，详细的需求也在附件中有些，麻烦老师帮忙看下，非常感谢

jamesz01

朱荣兴 发表于 2017-4-27 11:37
简单问题，下午看看

感谢老师，期待老师的答复

Kaohsing

ctr+g,定位一下可见单元格复制粘贴。

lsc900707

典型的按列拆分另存工作簿嘛，筛选干什么？

jamesz01

lsc900707 发表于 2017-4-27 11:41
典型的按列拆分另存工作簿嘛，筛选干什么？

老师您好，我明白您的意思，因为实际运用中这个表数据比较多，运算很慢，所以需要把筛选出来的值另存后单独使用，但是最终还是要将新建的工作薄复制回这个主表中，所以不能改变主表的结构，谢谢老师

jamesz01

Kaohsing 发表于 2017-4-27 11:41
ctr+g,定位一下可见单元格复制粘贴。

老师您好，因为实际运用中会有很多数据，每次都手动操作会比较麻烦，所以想用代码自动运行，谢谢老师

Kaohsing

jamesz01 发表于 2017-4-27 11:54
老师您好，因为实际运用中会有很多数据，每次都手动操作会比较麻烦，所以想用代码自动运行，谢谢老师

.AutoFilter.Range.SpecialCells(12).Copy Sheets("另一个表").Cells(1, 1)

lsc900707

jamesz01 发表于 2017-4-27 11:53
老师您好，我明白您的意思，因为实际运用中这个表数据比较多，运算很慢，所以需要把筛选出来的值另存后单 ...

自己先在同目录下建立“发货明细”文件夹：
Sub lsc()
    Set rng = Range("A1:J1")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [A1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
         s = Left(arr(i, 1), 1)
         If Not d.exists(s) Then
                Set d(s) = Cells(i, 1).Resize(1, 10)
            Else
                Set d(s) = Union(d(s), Cells(i, 1).Resize(1, 10))
         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 .[A2]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\发货明细\" & k(i), FileFormat:=xlExcel12
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

jamesz01

lsc900707 发表于 2017-4-27 12:28
自己先在同目录下建立“发货明细”文件夹：
Sub lsc()
    Set rng = Range("A1:J1")

老师您好，感谢您的帮助，但是我测试了您的代码有几个问题，第一是我想要筛选出来的内容能新建一个工作薄，而测试了您的代码，是将所有内容都新建一个工作薄了，能否麻烦老师再修改一下呢？第二是能否新建工作薄的名称根据筛选的值来命名？麻烦老师再看下，谢谢