VBS Enables automatic table sharding Based on the specified table Header

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"