VBS Enables automatic table sharding Based on the specified table Header

Source: Internet
Author: User

In our actual work, we often encounter the separation of the worksheet by a certain header field. Our general practice is to first sort the worksheet by the specified header and then copy and paste it out in segments, it is not only troublesome but also easy to make mistakes.

The following VBS script enables automatic table sharding for a worksheet Based on the specified table header (selected by the user. You only need to drag and drop the worksheet to be operated to the script file to easily implement worksheet sharding (currently only applicable to the XP system ):

Copy codeThe Code is as follows: 'drag the worksheet to the VBS script to achieve automatic table sharding Based on the specified Header
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
'Get the total number of initial worksheets.
SHCount = objExcel. Sheets. Count
'Get the number of valid worksheet Columns
MaxRows = objExcel. ActiveSheet. UsedRange. Rows. Count
MaxColumns = objExcel. ActiveSheet. UsedRange. Columns. Count
'Get the table header list of the first row of the worksheet.
Dim StrGroup
For I = 1 To MaxColumns
StrGroup = StrGroup & "[" & I & "]" & vbTab & objExcel. Cells (1, I). Value & vbCrLf
Next
'User-specified table shard header and input-ability legal judgment
Dim Num, HardValue
Num = InputBox ("Enter the sequence number of the table sharding Header" & 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
'Get the table sharding header value and table sharding count
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)
'Create a new SHEET and name it with the specified Header Value
For I = 0 To UBound ()
If I + 2> SHCount Then objExcel. Sheets. Add, objExcel. Sheets ("sheet" & I + 1), 1,-4167
Next
For I = 0 To UBound ()
ObjExcel. Sheets ("sheet" & I + 2). Name = HardValue & "_" & a (I)
Next
'Table sharding Data Writing
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 ()
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 ()
ObjExcel. sheets (HardValue & "_" & a (I). Select
ObjExcel. Cells (1, MaxColumns + 1). Value = ""
Next
ObjExcel. ActiveWorkbook. Save
ObjExcel. Quit
Set objExcel = Nothing
WScript. Echo "prompt: The table sharding operation for" & ExcelFile & "is completed"

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: info-contact@alibabacloud.com and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.