按照城市筛选并保存为不同的文件

orange8765

各位老师：如何按照城市筛选并保存为不同的文件

洋务德雷

你的是office还是wps？不同的办公软件，有不同的解法

orange8765

洋务德雷 发表于 2024-1-18 10:50
你的是office还是wps？不同的办公软件，有不同的解法

老师，您好！用的是WPS

洋务德雷

orange8765 发表于 2024-1-18 11:03
老师，您好！用的是WPS

WPS比较麻烦一些了。

x-xx-xx

就是简单的拆分嘛
WPS表格-智能工具箱-拆分表格-工作表按照内容拆分

喂你吃粑粑

office的excel可以运行，wps不确定，可以试试！

1. Sub 拆分城市数据()
   
2. Application.ScreenUpdating = False
   
3. Dim i As Integer, irow As Integer
   
4. Dim sht1 As Worksheet, sht2 As Worksheet
   
5. Dim wb As Workbook
   
6. Dim arr()
   
7. 
   
8. Set sht1 = ActiveSheet
   
9. irow = sht1.Range("c60000").End(xlUp).Row
   
10. arr = sht1.Range("k1:k" & irow)
    
11. mypath = ThisWorkbook.Path
    
12. Debug.Print mypath
    
13. For i = 2 To irow
    
14.     Filename = mypath & "" & arr(i, 1)
    
15.     If Dir(Filename, vbDirectory) = "" Then
    
16.         MkDir Filename
    
17.         Set wb = Workbooks.Add
    
18.         sht1.Range("a1:w" & irow).AutoFilter Field:=11, Criteria1:="=" & arr(i, 1)
    
19.         sht1.Range("a1:w" & irow).Copy wb.Sheets(1).Range("a1")
    
20.         wb.Sheets(1).Name = arr(i, 1)
    
21.         wb.SaveAs Filename & "\网元割接数据发布模板.xlsx"
    
22.         wb.Close
    
23.         Sheet1.Range("a1:f" & i).AutoFilter
    
24.     End If
    
25. Next
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

yynrzwh

原始表：2024.01.18 按照城市筛选并保存为不同的文件.rar (17.24 KB, 下载次数: 7)

2024-1-18 20:47 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.18
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     st = "网元割接数据发布模板"
   
9.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
10.     With sh
    
11.         r = .Cells(Rows.Count, "k").End(3).Row
    
12.         arr = .Range("a1:w" & r)
    
13.     End With
    
14.     For i = 2 To UBound(arr)
    
15.         s = arr(i, 11)
    
16.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
17.         d(s)(i) = i
    
18.     Next
    
19.     For Each k In d.keys
    
20.         sh.Copy
    
21.         Set wb = ActiveWorkbook
    
22.         m = 0
    
23.         p1 = p & k & ""
    
24.         If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
25.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
26.         With wb.Sheets(1)
    
27.             .Name = k
    
28.             .DrawingObjects.Delete
    
29.             .UsedRange.Offset(1 + d(k).Count).Clear
    
30.             For Each kk In d(k).keys
    
31.                 m = m + 1
    
32.                 For j = 1 To UBound(arr, 2)
    
33.                     brr(m, j) = arr(kk, j)
    
34.                 Next
    
35.             Next
    
36.             .[a2].Resize(m, UBound(arr, 2)) = brr
    
37.         End With
    
38.         wb.SaveAs p1 & st, 56
    
39.         wb.Close 1
    
40.     Next
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

ykcbf1100

附件供参考，代码调试通过。。。