VBA学习笔记 – 如何将Excel中的一个表格拆分为多个表格
如果工作中需要将一个大表按照某个字段拆分为不同的小表,例如如下左图按照名字字段来拆分,并将拆分后的小表按照所对应的字段命名,则可以使用如下代码:
Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Excel Header", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Excel Header", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub
运行代码后会分别有如下窗口弹出:
第一个就是选择表格标题,让vba知道哪一行是标题
第二就是选择拆分字段,然后就OK了
1个回复
-
xsmile
Sub 拆分工作簿到当前路径()
Dim wk As Workbook, ss$, k% '声明变量
Application.DisplayAlerts = False '将运行时弹出的对话框屏蔽掉
For Each sht In ActiveWorkbook.Sheets
Set wk = Workbooks.Add '新建一个工作簿,并且这个工作簿赋值给变量wk
k = k + 1 'k的作用在下一句就能看明白
Workbooks(1).Sheets(k).Copy Workbooks(2).Sheets(1)
'前面完成了新建工作簿,现有两个工作簿,原有的为Workbooks(1),新建的为Workbooks(2),这句代码的含义是将当前工作簿下面的工作表Sheet(k)复制到新建工作簿的Sheet(1)前面
ss = ThisWorkbook.Path & "\" & sht.Name & ".xlsx" '给ss变量赋值为当前工作簿的路径+取出来的文件名
wk.Sheets(2).Delete
wk.SaveAs ss '保存wk工作簿
wk.Close '关闭wk工作簿
Next
Application.DisplayAlerts = True '解除前面的屏蔽
MsgBox "拆分已完成!"
End Sub
from 第037篇:VBA之拆分工作簿(将一个包含多工作表的工作簿拆分为单工作表工作簿文件)
1年前 我来评论