VBS實(shí)現(xiàn)工作表按指定表頭自動(dòng)分表

更新時(shí)間：2013年01月14日 17:51:11 作者：

下面的VBS腳本就是實(shí)現(xiàn)的工作表按指定表頭（由用戶選擇）自動(dòng)分表功能。需要的朋友只要將要操作的工作表拖放到腳本文件上即可輕松實(shí)現(xiàn)工作表分表

在我們實(shí)際工作中經(jīng)常遇到將工作表按某一表頭字段分開(kāi)的情況，我們一般的做法是先按指定表頭排序然后分段復(fù)制粘貼出去，不但麻煩還很容易搞錯(cuò)。

下面的VBS腳本就是實(shí)現(xiàn)的工作表按指定表頭（由用戶選擇）自動(dòng)分表功能。需要的朋友只要將要操作的工作表拖放到腳本文件上即可輕松實(shí)現(xiàn)工作表分表（暫時(shí)只適用于xp系統(tǒng)）：

復(fù)制代碼代碼如下:

 
'拖動(dòng)工作表至VBS腳本實(shí)現(xiàn)按指定表頭自動(dòng)分表 
On Error Resume Next 
If WScript.Arguments(0) = "" Then WScript.Quit 
Dim objExcel, ExcelFile, MaxRows, MaxColumns, SHCount 
ExcelFile = WScript.Arguments(0) 
If LCase(Right(ExcelFile,4)) <> ".xls" And LCase(Right(ExcelFile,4)) <> ".xls" Then WScript.Quit 
Set objExcel = CreateObject("Excel.Application") 
objExcel.Visible = False 
objExcel.Workbooks.Open ExcelFile 
'獲取工作表初始sheet總數(shù) 
SHCount = objExcel.Sheets.Count 
'獲取工作表有效行列數(shù) 
MaxRows = objExcel.ActiveSheet.UsedRange.Rows.Count 
MaxColumns = objExcel.ActiveSheet.UsedRange.Columns.Count 
'獲取工作表首行表頭列表 
Dim StrGroup 
For i = 1 To MaxColumns 
StrGroup = StrGroup & "[" & i & "]" & vbTab & objExcel.Cells(1, i).Value & vbCrLf 
Next 
'用戶指定分表表頭及輸入性合法判斷 
Dim Num, HardValue 
Num = InputBox("請(qǐng)輸入分表表頭的序號(hào)" & vbCrLf & StrGroup) 
If Num <> "" Then 
Num = Int(Num) 
If Num > 0 And Num <= MaxColumns Then 
HardValue = objExcel.Cells(1, Num).Value 
Else 
objExcel.Quit 
Set objExcel = Nothing 
WScript.Quit 
End If 
Else 
objExcel.Quit 
Set objExcel = Nothing 
WScript.Quit 
End If 
'獲取分表表頭值及分表數(shù) 
Dim ValueGroup : j = 0 
Dim a() : ReDim a(10000) 
For i = 2 To MaxRows 
str = objExcel.Cells(i, Num).Value 
If InStr(ValueGroup, str) = 0 Then 
a(j) = str 
ValueGroup = ValueGroup & str & "," 
j = j + 1 
End If 
Next 
ReDim Preserve a(j-1) 
'創(chuàng)建新SHEET并以指定表頭值命名 
For i = 0 To UBound(a) 
If i + 2 > SHCount Then objExcel.Sheets.Add ,objExcel.Sheets("sheet" & i + 1),1,-4167 
Next 
For i = 0 To UBound(a) 
objExcel.Sheets("sheet" & i + 2).Name = HardValue & "_" & a(i) 
Next 
'分表寫數(shù)據(jù) 
For i = 1 To MaxRows 
For j = 1 To MaxColumns 
objExcel.sheets(1).Select 
str = objExcel.Cells(i,j).Value 
If i = 1 Then 
For k = 0 To UBound(a) 
objExcel.sheets(HardValue & "_" & a(k)).Select 
objExcel.Cells(i,j).Value = str 
objExcel.Cells(1, MaxColumns + 1).Value = 1 
Next 
Else 
objExcel.sheets(HardValue & "_" & objExcel.Cells(i,Num).Value).Select 
If j = 1 Then x = objExcel.Cells(1, MaxColumns + 1).Value + 1 
objExcel.Cells(x ,j).Value = str 
If j = MaxColumns Then objExcel.Cells(1, MaxColumns + 1).Value = x 
End If 
Next 
Next 
For i = 0 To UBound(a) 
objExcel.sheets(HardValue & "_" & a(i)).Select 
objExcel.Cells(1, MaxColumns + 1).Value = "" 
Next 
objExcel.ActiveWorkbook.Save 
objExcel.Quit 
Set objExcel = Nothing 
WScript.Echo "提示：對(duì)" & ExcelFile & "的分表操作完成" 