excel 宏把一个工作表按照某几个列拆分为多个工作表

您所在的位置：网站首页 › 拆分表格函数 › excel 宏把一个工作表按照某几个列拆分为多个工作表

excel 宏把一个工作表按照某几个列拆分为多个工作表

2024-02-21 10:08| 来源: 网络整理| 查看: 265

前言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工作表中标签处右键查看代码在这里插入图片描述