Public Sub split()
cWBName = ActiveWorkbook.Name
cWBFullName = ActiveWorkbook.FullName
cWBPath = ActiveWorkbook.Path
Dim cWB As Workbook
Set cWB = ActiveWorkbook
Dim cWS As Worksheet
Set cWS = ActiveSheet
cFolderName = cWBPath & "\" & Left(cWBName, Len(cWBName) - 4)
'MkDir (cWBPath & "\" & Left(cWBName, Len(cWBName) - 3))
'Dim fs As New FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(cFolderName) Then
fs.CreateFolder (cFolderName)
End If
Set cRow1 = cWS.Range("1:1").Find("物料组")
cColNo = cRow1.Column
Set cRows = cWS.Columns(cColNo).Rows
For Each cCell In cRows
If cCell.Row = 1 Then
GoTo next1
End If
sFileName = cCell.Value
sFileFullName = cFolderName & "\" & sFileName & ".xls"
If Not fs.FileExists(sFileFullName) Then
'fs.CopyFile cWBFullName, sFileFullName
'Dim dWB As New Workbook
Set dWB = Workbooks.Add
'dWB.Windows(1).Visible = False
dWB.SaveAs (sFileFullName)
'Set dWB = Workbooks.Open(sFileFullName)
Set dWS = dWB.ActiveSheet
'Set dRows = dWS.Columns(cColNo).Rows
Set cRange = cWS.Rows(1)
For Each iCell In cRows
If iCell.Row = 1 Then
GoTo next2
End If
If iCell.Value = sFileName Then
'dWS.Rows(dCell.Row).Delete
Set cRange = Union(cRange, cWS.Rows(iCell.Row))
'cCollection.Add cWS.Rows(iCell.Row)
End If
next2:
Next
cRange.Copy dWS.Cells(1, 1)
dWB.Save
dWB.Close
End If
next1:
Next
End Sub