从多个sheet中按拆分列拆分

banyun123

各位老师好，有个拆分的问题。


想从原表格中只拆分留1和留2的sheet，其他的sheet都不要。 然后再按留1和留2的拆分列拆分。

附件有原表和想要的最终效果。

谢谢各位老师，要有哪里写不明白的可以问

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.21
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     fns = [{"留1","留2"}]
   
5.     b = [{9,15}]
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     p = ws.Path & ""
   
9.     fn = Split(ws.Name, ".")(0)
   
10.     For x = 1 To UBound(b)
    
11.         With Sheets(fns(x))
    
12.             r = .Cells(Rows.Count, b(x)).End(3).Row
    
13.             For i = 10 To r
    
14.                 s = .Cells(i, b(x))
    
15.                 d(s) = ""
    
16.             Next
    
17.         End With
    
18.     Next
    
19.     On Error Resume Next
    
20.     For Each k In d.keys
    
21.         ws.Sheets(fns).Copy
    
22.         Set wb = ActiveWorkbook
    
23.         For x = 1 To UBound(b)
    
24.             With wb.Sheets(fns(x))
    
25.                 .DrawingObjects.Delete
    
26.                 r = .Cells(Rows.Count, b(x)).End(3).Row
    
27.                 c = .UsedRange.Columns.Count
    
28.                 arr = .Range("a9").Resize(r + 100, c)
    
29.                 .Range("a9").Resize(r + 100, c).Copy .[a1]
    
30.                 .UsedRange.Offset(1).Clear
    
31.                 ReDim brr(1 To UBound(arr), 1 To c)
    
32.                 m = 0
    
33.                 For i = 2 To UBound(arr)
    
34.                     s = arr(i, b(x))
    
35.                     If s = k Then
    
36.                         m = m + 1
    
37.                         For j = 1 To UBound(arr, 2)
    
38.                             brr(m, j) = arr(i, j)
    
39.                         Next
    
40.                     End If
    
41.                 Next
    
42.                 .[a2].Resize(m, UBound(arr, 2)) = brr
    
43.             End With
    
44.         Next
    
45.         wb.SaveAs p & fn & "-" & k
    
46.         wb.Close
    
47.     Next
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码

banyun123

ykcbf1100 发表于 2024-2-21 19:00
参与一下。。。

老师好，我试着运行了一下，发现没有拆分后的文件生成。

ykcbf1100

banyun123 发表于 2024-2-22 09:35
老师好，我试着运行了一下，发现没有拆分后的文件生成。

原表-A，原表-B，原表-C，这就是拆分后的新工作簿啊

新文件在当前目录下。

shiruiqiang

banyun123 发表于 2024-2-22 09:35
老师好，我试着运行了一下，发现没有拆分后的文件生成。

你把同文件夹下的其他文件删除了，然后拆分

banyun123

好的好的，现在好了。让我学习一下啊。谢谢二位老师

banyun123

ykcbf1100 发表于 2024-2-22 09:57
原表-A，原表-B，原表-C，这就是拆分后的新工作簿啊

新文件在当前目录下。

已经看明白了，再次感谢