和上一篇的合并工作簿配合使用
附上源码
Sub 拆分()
Dim wb As Workbook
Dim newWb As Workbook
Dim ws As Worksheet
Dim newWs As Worksheet
Dim cell As Range
Dim fileName As String
Dim filePath As String
Dim folderPatn As String
Dim arr() As String
filePath = SelectFile
Set wb = Workbooks.Open(filePath)
folderPatn = CreateFolder
Set ws = wb.Worksheets("Sheet1")
For Each cellA In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row) ' 这里假设要根据A列的值进行拆分
If cellA.Value <> "" Then
fileName = cellA.Value ' 这里假设每个单元格的值作为文件名
Set newWb = Workbooks.Add
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For i = 2 To lastRow
Dim data As Variant
data = ws.Cells(i, "B").Value
If data <> "" Then
arr = Split(data, "-")
'workBookName = ws.Range("A" & arr(0))
If (arr(0) = cellA.Row) Then
'MsgBox data & " ---- " & fileName
Set Worksheet = wb.Worksheets(data)
'Worksheet.Name = arr(1)
Worksheet.Copy after:=newWb.Sheets(newWb.Sheets.Count)
' 删除原来的默认工作表(Sheet1)
Application.DisplayAlerts = False ' 关闭删除时的确认提示
newWb.Worksheets("Sheet1").Delete
Application.DisplayAlerts = True ' 重新开启删除时的确认提示
Set NewSheet = newWb.Sheets(newWb.Sheets.Count)
NewSheet.Name = arr(1)
End If
End If
Next i
' 保存新的工作簿
newWb.SaveAs folderPatn & "\" & fileName
newWb.Close
End If
Next cellA
' 关闭原始工作簿
wb.Close
End Sub
Function CreateFolder()
Dim fso As Object
Dim desktopPath As String
Dim newFolder As Object
Dim folderName As String
' 创建FileSystemObject对象
Set fso = CreateObject("Scripting.FileSystemObject")
' 获取桌面路径
desktopPath = Environ("USERPROFILE") & "\Desktop\ NewFolder"
If fso.FolderExists(desktopPath) Then
fso.DeleteFolder desktopPath, True
'MsgBox "文件夹已创建:" & folderPath
End If
fso.CreateFolder (desktopPath)
' 释放对象
Set newFolder = Nothing
Set fso = Nothing
MsgBox "文件夹已成功创建在桌面上。"
CreateFolder = desktopPath
End Function