跟着一起学《Excel VBA跟卢子一起学 早做完 不加班 基础入门版》_1.1.1 一键拆分工作表

【摘要】 本书摘自《Excel VBA跟卢子一起学 早做完 不加班 基础入门版》一书中第1章，第1节，韩小良著。

1.1.1 一键拆分工作表

有一天，在Excel解答群中某位网友焦急地说，需要将某个工作表按照指定的标题进行拆分， 但她还是个新手，不知该怎么办。此时，大家说出了好几种方法：筛选复制粘贴、数据透视表、宏。 但是无论大家说什么,妹子(鱼儿)都回应道：“我不熟悉啊，你们说的我都很陌生，怎么办?”

无言刚好打开群看到了，于是回复： “那我给你整个宏，然后你将代码复制到这个工作簿， 单击表中的按钮，按照提示做下去就行了，可以吗?”

? 网友： 好的，麻烦你了。

无言：已经发共享了，你去下载名为“一键拆分工作表”的文件，然后单击表中的按钮即可。 ? 网 友 ：好的，我去下载!

? 网友：无言，不行啊，我按了没有反应呢，怎么办?

无言：啊……

无言：好吧，我刚才忘了和你说明白，看来你也没有使用过宏。

先关闭该 Excel文件，然后再次打开，你将看到如图1-8所示的提示——【安全警告宏已 被禁用。】的旁边有一个【启用内容】按钮，单击它即可。接下来，只需要单击工作表中已经 设定好的【一键拆分工作表】按钮，就可以获得根据指定标题拆分的内容不重复的新表。如图1-9 所示，单击后工作簿中多了4个以【职业】标题拆分的新工作表。也可以选择其他列标题内容

进行拆分，例如性别、学历来获取需要的分表内容。

? 网友： 好的，我操作下，谢谢哈!

趁着网友去操作的间隙，无言将写好的代码复制、粘贴，发送到群里，并交代“大家也可 以看看，在工作簿中有具体的代码语句说明，如代码1-2所示”。

代码1-2 一键拆分工作表

Sub YijianChaifenSheet()

Dim Zd As Object,FbKey,Fbltem,ZdCou As Long,RngArr

Dim Sht As Worksheet,MxR As Long,MxC As Integer

Dim BtArr,BtMt As String,Mte As Integer

Dim ShArr(),Ccou As Integer,Rcou As Long,Cous As Long

Application.ScreenUpdating=False: Application.DisplayAlerts=False

For Each Sht In Worksheets

If Sht.CodeName ～ Sheetl Then Sht.Delete

Next Sht

With Sheetl

MxR=.Cells(1).End(xIDown).Row

MxC=.Cells(1).End(xIToRight).Column

BtArr=.Cells(1).Resize(1,MxC).Value

BtMt=Application.InputBox(“"请输入需要拆分的标题名称，默认以【职业】拆分，拆分关键字，"

"职业",,,,,2)

If BtMt=Then MsgBox"输入关键字不正确，过程将退出!":Exit Sub

On Error Resume Next

Mtc=WorksheetFunction.Match(BtMt,BtArr,0)

If Err.Number ～0 Then MsgBox"输入的标题名称不存在，过程将退出",vbOKOnly:Exit Sub RngArr=.Cells(1).Resize(MxR,MxC).Value

Set Zd =CreateObject(Scripting.Dictionary)

21| On Error GoTo 0

221 For ZdCou =2 To MxR

23|If Not (Zd.Exists(RngArr(ZdCou,Mtc)))Then

24| Zd.Add RngArr(ZdCou,Mtc),1

25|Else

26| Zd(RngArr(ZdCou,Mtc))=Zd(RngArr(ZdCou,Mtc))+1

27|End If

28| Next ZdCou

29| FbKey=Zd.Keys:FbItem =Zd.Items

30| For ZdCou=0 To Zd.Count-1

31| ReDim ShArr(1 To Fbltem(ZdCou),1 To MxC)

32| For Rcou=2 To MxR

33| If RngArr(Rcou,Mtc)=FbKey(ZdCou)Then

34 Cous=Cous+1

35| For Ccou =1 To MxC

36| ShArr(Cous,Ccou)=RngArr(Rcou,Ccou)

37| Next Ccou

38| If Cous=Fbltem(ZdCou)Then Cous=0:Exit For

39| End If

40| Next Rcou

41| With Worksheets.Add(After:=Worksheets(Worksheets.Count),Count:=1)

42| .Name =FbKey(ZdCou)

43| Sheet1.Rows(1).Copy.Cells(1)

44| .Cells(1).Offset(1).Resize(Fbltem(ZdCou),MxC)=ShArr

45| .UsedRange.Borders.LineStyle =1

46| .UsedRange.Columns.AutoFit

471 End With

48| Erase ShArr

49| Next ZdCou

50| End With

51| Application.DisplayAlerts =True:Application.ScreenUpdating=True

521 MsgBox”依据关键字，拆分工作表，已完成!”

53|End Sub

一键合并工作表

群里的每一天都会有不同的、新鲜的、火辣的问题亟待解决。这不，某天群内又一位网友 (鳄鱼)有问题。

? 网友：请问大家，谁能告诉我如何合并Excel工作簿里的所有工作表呢?谢谢!比较急， 我先上传一个模拟文件，请大家帮下忙。

这下群里又开始讨论了——这么少，手工复制就可以了；要不用SQL 吧，或者用多重数 据透视表、宏也行。

网友：手工不行啊!我只是模拟了十来个，实际上有差不多二百多个工作表呢。还有你们 说的SQL我完全不懂；数据透视表我操作了，感觉不是我要的结果；宏的话我也不会，只能请 大家帮下我了，要不今晚加班都可能搞不定。

无言：我给你弄一段宏，稍等会儿。

这个话题停止了讨论，但是群内的问题是不断的。只是无言也无暇理会其他了——正在忙 着给鳄鱼弄一键合并工作表的宏。时间又过了差不多十多分钟。

无言：好了，我将文件发到共享了，你去下载吧。注意使用时根据提示启用宏，如果不明 白请先百度一下，再单击表中的【一键合并工作表按钮】按钮，如图1-10所示。网友：谢谢大家，谢谢无言。刚才的模拟表简直是瞬间完成；真实的文件不到一分钟也完 成了，效果很不错。我今晚不用加班了，可以准时下班回家了。对了，无言，能说下这段代码 的大概作用吗?

无言：可以啊。这个宏过程主要通过已经建立的一个名为“合并工作表”的工作表，然后

通过判断工作表名是不是与其相同，如果不同，则通过让用户选择内容循环获取具体的数据范 围，并将这些数据复制到“合并工作表”中，具体的代码如代码1-3所示，但还是希望大家下 载 Excel 文 件 ， 每 条 代 码 都 有 详 细 的 注 释 。

版权声明：本文内容由网络用户投稿，版权归原作者所有，本站不拥有其著作权，亦不承担相应法律责任。如果您发现本站中有涉嫌抄袭或描述失实的内容，请联系我们 18664393530@aliyun.com 处理，核实后本网站将在24小时内删除侵权内容。