求助，怎么摆脱excel 简单的复制粘贴操作。。

2380123779

大神们，我现在需要筛选店铺名称（sheet表服务费的E列，税费的D列），把每个店铺产生的服务费、税费单独做成一个excel表，实现的效果是会生成65个店铺命名的excel，每个excel表还是会有服务费、税费这两项，并需要保留表头，之前我都是筛选-复制-粘贴，发现越来越费劲了，特来求助，希望有好心人帮助一下，最好再来一份注释，我也学着自己操作。

泊蓝

1、数据透视表，将店铺名称放到筛选
2、显示报表筛选页，分解为65个工作表
3、插件“易用宝”，工作簿管理，拆分工作簿

2380123779

泊蓝 发表于 2018-8-17 16:28
1、数据透视表，将店铺名称放到筛选
2、显示报表筛选页，分解为65个工作表
3、插件“易用宝”，工作簿管 ...

好的，我先去试试

xiaohoe

我也不太懂，但是找到公式可用

2380123779

xiaohoe 发表于 2018-8-17 17:25
我也不太懂，但是找到公式可用

可能是我没表达清楚，我需要表格里的所有内容，只是要根据店铺名称去筛选全选 复制到新的excel,这样会形成65份excel工作表，但现在要优化一下，怎么才能代替这种筛选-复制的傻瓜模式，还是很谢谢你的回复。

xiangbaoan

'盆友，帮你一把，江湖救急，不必言谢，拿走就行，若有鲜花，来者不拒…………
Sub test()
Dim p$, d1 As Object, d2 As Object, ar, rng1 As Range, rng2 As Range, r&, i%, nm$
Application.ScreenUpdating = False
p = ThisWorkbook.Path & "\店铺拆分文件"
If Dir(p, vbDirectory) = "" Then MkDir p
p = p & "\"
Set d1 = CreateObject("scripting.dictionary")
With Sheet1
    Set rng1 = .[a1].Resize(1, 12)
    ar = .Range("e1:e" & .[e65536].End(3).Row)
    For r = 2 To UBound(ar)
        If Len(ar(r, 1)) Then
            If Not d1.exists(ar(r, 1)) Then
                Set d1(ar(r, 1)) = .Cells(r, 1).Resize(1, 12)
            Else
                Set d1(ar(r, 1)) = Union(d1(ar(r, 1)), .Cells(r, 1).Resize(1, 12))
            End If
        End If
    Next
End With
Set d2 = CreateObject("scripting.dictionary")
With Sheet2
    Set rng2 = .[a1].Resize(1, 24)
    ar = .Range("d1:d" & .[d65536].End(3).Row)
    For r = 2 To UBound(ar)
        If Len(ar(r, 1)) Then
            If Not d2.exists(ar(r, 1)) Then
                Set d2(ar(r, 1)) = .Cells(r, 1).Resize(1, 24)
            Else
                Set d2(ar(r, 1)) = Union(d2(ar(r, 1)), .Cells(r, 1).Resize(1, 24))
            End If
        End If
    Next
End With
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 2
For i = 0 To d1.Count - 1
    nm = d1.keys()(i)
    With Workbooks.Add
        With .Sheets(1)
            .Name = "服务费"
            rng1.Copy .[a1]
            d1.items()(i).Copy .[a2]
            .[a:l].EntireColumn.AutoFit
        End With
        With .Sheets(2)
            .Name = "税费"
            rng2.Copy .[a1]
            If d2.exists(nm) Then d2(nm).Copy .[a2]
            .[a:x].EntireColumn.AutoFit
        End With
        .SaveAs p & nm & ".xlsx", xlOpenXMLWorkbook
        .Close
    End With
Next
Set rng1 = Nothing
Set rng2 = Nothing
Set d1 = Nothing
Set d2 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = False
MsgBox "OK!"
End Sub'附件有2M多，无法上传

xiangbaoan

附件中两个表，我都删除了后面几千行，不然附件有2.3M，无法上传，你测试时，请将数据补充完整。