[求助]excel文件根据某一列拆分成多个工作表/工作簿并分别设置不同密码

fzxba

慢慢来不急 发表于 2024-2-8 10:10
感谢大佬！试了没问题，就是我想要的~~~

这是拆分成表的.zip (44.97 KB, 下载次数: 13)

2024-2-8 10:13 上传

点击文件名下载附件

慢慢来不急

3190496160 发表于 2024-2-8 10:06
拆分为工作簿，两种文件类型，供参考

感谢大佬分享！这个可以每次自定义输入标题行和拆分列的列号，更灵活欸~赞~

慢慢来不急

fzxba 发表于 2024-2-8 10:14

大佬，这个拆分工作表的好像有问题，我看下载文件已经是有多个工作表了，且无密码。尝试把地区的工作表删除后重新运行宏，还是会自动生成工作簿呢~

fzxba

慢慢来不急 发表于 2024-2-8 10:27
大佬，这个拆分工作表的好像有问题，我看下载文件已经是有多个工作表了，且无密码。尝试把地区的工作表删 ...

非也……非也……

慢慢来不急

fzxba 发表于 2024-2-8 10:35
非也……非也……

我理解的是，大佬你第二个宏，想实现的是根据城市这一列数据，在原有基础上拆分出多个工作表，并对每个工作表设置不同的密码。这个也能满足我的需求~~
不过我点击操作后结果跟这个不一样~所以是我哪儿理解或者操作错了么？

fzxba

慢慢来不急 发表于 2024-2-8 10:43
我理解的是，大佬你第二个宏，想实现的是根据城市这一列数据，在原有基础上拆分出多个工作表，并对每个工 ...

模块2有4法，自己去添加按钮并关联相关宏后运行。

慢慢来不急

fzxba 发表于 2024-2-8 10:53
模块2有4法，自己去添加按钮并关联相关宏后运行。

哦哦，get了~
刚试了另外4个宏，可以将数据根据城市列拆分成不同的不同工作表。感谢~~~

cai2532

根据某一列拆分成多个工作表工作簿并分别设置不同密码VBA

ykcbf1100

一表拆分为多表，工作表加密码保护，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.9
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     arr = Sheets("密码").UsedRange
   
8.     For i = 2 To UBound(arr)
   
9.         d1(arr(i, 1)) = arr(i, 2)
   
10.     Next
    
11.     Set sh = ThisWorkbook.Sheets("数据")
    
12.     For Each sht In Sheets
    
13.         If sht.Name <> "密码" And sht.Name <> sh.Name Then
    
14.             sht.Delete
    
15.         End If
    
16.     Next
    
17.     arr = sh.UsedRange
    
18.     For i = 2 To UBound(arr)
    
19.         s = arr(i, 2)
    
20.         If Not d.Exists(s) Then
    
21.             Set d(s) = CreateObject("scripting.dictionary")
    
22.         End If
    
23.         d(s)(i) = i
    
24.     Next i
    
25.     For Each k In d.keys
    
26.         sh.Copy after:=Sheets(Sheets.Count)
    
27.         Set sht = Sheets(Sheets.Count)
    
28.         m = 0
    
29.         ReDim brr(1 To d(k).Count, 1 To 4)
    
30.         With sht
    
31.             .Name = k
    
32.             .DrawingObjects.Delete
    
33.             For Each kk In d(k).keys
    
34.                 m = m + 1
    
35.                 For j = 1 To UBound(arr, 2)
    
36.                     brr(m, j) = arr(kk, j)
    
37.                 Next
    
38.             Next
    
39.             .[a2].Resize(m, 4) = brr
    
40.             .Protect d1(k), UserInterfaceOnly:=True
    
41.         End With
    
42.     Next k
    
43.     sh.Activate
    
44.     Set d = Nothing
    
45.     Application.DisplayAlerts = True
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
48. End Sub
    

复制代码