如何一键组合筛选+生成新文件复制粘贴保存重命名

l3702131994

小白请各位大神指教！
如何一键将“会员ID.xlsx”文件中的两列信息进行“目的地”筛选后，
将不同目的地对应的“会员ID”生成一个新*xlsx，文件命名为该目的地，
一键生成多个“目的地.xlsx”，每个文件内仅包含一列数据“ID号码”
宏或者VBA是否可以实现上述步骤？
非常感谢！

l3702131994

疑难疑难，求助 T T

刀羊

几个不相关的操作一键完成，不用代码恐怕做不到。

l3702131994

刀羊 发表于 2017-5-31 22:09
几个不相关的操作一键完成，不用代码恐怕做不到。

多次操作有木有办法？，主要是目的地较多，省略对不同目的地的筛选复制粘贴操作

秋枫

拆分成多个文件.zip (911 Bytes, 下载次数: 35)

2017-5-31 22:48 上传

点击文件名下载附件

提供一个脚本程序。
使用方法：
打开你的 会员ID.xlsx文件
然后双击附件中提供的 拆分成多个文件.vbs 脚本。
在 会员ID.xlsx 所在的文件夹中，生成多个目标文件。

如何修改程序？
在 vbs 脚本上右键，选编辑。

Enjoy it

秋枫

代码全文如下：

1. ' This code try to connect WPS ET，if failed then connect to Excel
   
2. Dim ExcelApp
   
3. 
   
4. On Error Resume Next
   
5. ' try to connect to et or excel
   
6. Set ExcelApp = GetObject(, "Excel.Application")
   
7. If ExcelApp Is Nothing Then
   
8.         Set ExcelApp = GetObject(, "KET.Application")
   
9.         If ExcelApp Is Nothing Then
   
10.                 Set ExcelApp = GetObject(, "ET.Application")
    
11.                 If ExcelApp Is Nothing Then
    
12.                         MsgBox "Run Excel or Kingsoft ET first.", vbInformation, "Information"
    
13.                         WScript.Quit
    
14.                 End If
    
15.         End If
    
16. End If
    
17. On Error Goto 0
    
18. 
    
19. Dim Workbook, ActiveSheet
    
20. Set Workbook = ExcelApp.ActiveWorkbook
    
21. Set ActiveSheet = Workbook.ActiveSheet
    
22. 
    
23. Dim MaxRow, MaxCol
    
24. MaxRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count-1
    
25. MaxCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count-1
    
26. 
    
27. Dim Dict
    
28. Set Dict = CreateObject("Scripting.Dictionary")
    
29. Dim key, r
    
30. 
    
31. For r = 2 To MaxRow
    
32.         key = ActiveSheet.Cells(r,1).value
    
33.         If dict.Exists(key) Then
    
34.                 dict(key)=dict(key) & ";" & ActiveSheet.Cells(r,2).Value
    
35.         Else
    
36.                 dict.Add key, ActiveSheet.Cells(r,2).Value
    
37.         End If
    
38. Next
    
39. 
    
40. Dim FileName, WB, IDs
    
41. For Each FileName In dict.keys
    
42.         Set WB=ExcelApp.Workbooks.Add
    
43.         IDs = Split(dict(FileName),";")
    
44.         For r = 1 To UBound(IDs)+1
    
45.                 wb.activesheet.cells(r,1)=IDs(r-1)
    
46.         Next
    
47.         WB.SaveAs workbook.path & "" & filename & ".xlsx"
    
48.         WB.Close false
    
49. Next

复制代码

l3702131994

秋枫 发表于 2017-5-31 22:50
提供一个脚本程序。
使用方法：
打开你的 会员ID.xlsx文件

感谢大神造福社会~~~非常感谢

ccyinger

秋枫 发表于 2017-5-31 22:51
代码全文如下：

老师，有个问题想请问下您，这份代码如果我改筛选后，复制全部内容，包括格式，要怎么变动呢？