- 前言
- step 1 进入excel vba编程界面
- step 2 粘贴代码
- step 3 运行代码
- step 4 删除宏代码
前言
这两天接触到excel比较多,才发现使用excel不仅仅是简单的复制粘贴。
excel vb代码是非常强大,学会使用一些常用的功能,可以大大减少工作量。
废话不多少,来看
如下表格学生成绩表
如果我们要把这个表按照班级拆分为三个表,可能一般我们都是通过筛选后复制粘贴。但这是最土的办法,并且如果分类很多,数据量又大的话,非常浪费时间。
来看使用excel宏轻松搞定。excel宏代码如下:
Option Explicit
Option Base 1
Sub 按指定列分组拆分数据()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim self As Worksheet
Set self = ActiveSheet
Dim nLastRowNum As Long
Dim nLastColumnNum As Long
Dim i As Long
' 删除其他的sheet
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name <> self.Name Then
Sheets(i).Delete
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'获取全部数据范围
nLastRowNum = Cells(Rows.Count, 1).End(xlUp).Row
nLastColumnNum = Cells(nLastRowNum, Columns.Count).End(xlToLeft).Column
'获取标题
Dim titleRange As Range
Set titleRange = Application.InputBox(prompt:="请选择标题区域:将要当做标题行的每一个单元格", Type:=8)
' 有效数据开始行
Dim nRowValidData As Long
nRowValidData = titleRange.Row + titleRange.Rows.Count
' 获取拆分列的信息,只需要列号
Dim splitColumnRange As Range
Set splitColumnRange = Application.InputBox(prompt:="请选择拆分的列:选择任何一个该列的单元格即可", Type:=8)
Dim columnNumToSplit As Long
columnNumToSplit = splitColumnRange.Column
' 需要拆分的值字典
Dim splitValueDict As Object
' 辅助字典用来保证顺序
Dim splitValueDictReverse As Object
Dim indexArray() As Long
Set splitValueDict = CreateObject("Scripting.Dictionary")
Set splitValueDictReverse = CreateObject("Scripting.Dictionary")
Dim cellValue As String
Dim ws As Worksheet
For i = nRowValidData To nLastRowNum Step 1
cellValue = Cells(i, columnNumToSplit).Text
'1. 创建新的sheet;
'2. 拷贝标题信息到新的sheet
If Not splitValueDict.Exists(cellValue) Then
splitValueDict(cellValue) = i
splitValueDictReverse(i) = cellValue
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = cellValue
self.Activate
titleRange.Copy _
ws.Range(ws.Cells(titleRange.Row, titleRange.Column), ws.Cells(nRowValidData - 1, titleRange.Column))
End If
' 拷贝其他内容
Range(Cells(i, 1), Cells(i, nLastColumnNum)).Copy _
GetLastPasteRangeBySheetName(cellValue, nLastColumnNum)
Next i
End Sub
Public Function GetLastPasteRangeBySheetName(ByRef SheetName As String, columnNum As Long) As Variant
Dim wks As Worksheet
Dim nLastRowNum As Long
Set wks = ActiveWorkbook.Worksheets(SheetName)
nLastRowNum = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
Set GetLastPasteRangeBySheetName = wks.Range(wks.Cells(nLastRowNum + 1, 1), wks.Cells(nLastRowNum + 1, columnNum))
End Function
step 1 进入excel vba编程界面
在excel工作表中标签处右键查看代码
进入如下界面
step 2 粘贴代码
然后把代码粘贴窗口中如下图:
step 3 运行代码
点击下图中红框按钮
出现下面弹框
选择需要拆分标题区域。只需要用鼠标拖动选择区域即可
确定后再选择拆分的单元格,即按照班级拆分,选择班级
确定,结果如下
step 4 删除宏代码
如果为了保存方便,我们需要把宏代码删掉,不然保存需要保存为支持宏的格式。
运行成功后删除宏
找到工具 选择宏。
删除刚刚的宏即可,然后关闭代码,保存即可