'拖動工作表至VBS腳本實現按指定表頭自動分表 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總數 SHCount = objExcel.Sheets.Count '獲取工作表有效行列數 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("請輸入分表表頭的序號" & 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 '獲取分表表頭值及分表數 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) '創建新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 '分表寫數據 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 "提示：對" & ExcelFile & "的分表操作完成"
