|
|
楼主 |
发表于 2025-3-13 15:53
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
不好意思，代码未上传
Sub SplitWorkbooksByPerson()
Dim sourceWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim selectedFile As String
Dim dict As Object
Dim ws As Worksheet
Dim person As Variant
Dim newWorkbookPath As String
Dim sourceWorkbookName As String
Dim currentDate As String
Dim personName As String
' 设置日期格式
currentDate = Format(Date, "yyyy-m-d")
' 选择文件对话框
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选择要拆分的工作簿"
.Filters.Clear
.Filters.Add "Excel文件", "*.xlsx;*.xls"
If .Show = -1 Then
selectedFile = .SelectedItems(1)
Else
MsgBox "未选择文件，程序退出。"
Exit Sub
End If
End With
' 打开源工作簿
Set sourceWorkbook = Workbooks.Open(selectedFile)
sourceWorkbookName = CleanFileName(Replace(sourceWorkbook.Name, ".xlsx", ""))
sourceWorkbookName = CleanFileName(Replace(sourceWorkbookName, ".xls", ""))
' 创建字典收集唯一姓名
Set dict = CreateObject("Scripting.Dictionary")
CollectNames sourceWorkbook, dict
If dict.Count = 0 Then
MsgBox "源工作簿中没有有效数据。"
sourceWorkbook.Close False
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' 遍历每个人员
For Each person In dict.Keys
personName = CleanFileName(CStr(person))
' 创建新工作簿
Set targetWorkbook = Workbooks.Add
RemoveInitialSheet targetWorkbook
' 处理每个工作表
ProcessWorksheets sourceWorkbook, targetWorkbook, person
' 保存并关闭工作簿
If targetWorkbook.Worksheets.Count > 0 Then
newWorkbookPath = GenerateUniquePath(sourceWorkbook, sourceWorkbookName, personName, currentDate)
targetWorkbook.SaveAs newWorkbookPath, xlOpenXMLWorkbook
MsgBox "已创建文件：" & newWorkbookPath
End If
targetWorkbook.Close False
Next person
Application.ScreenUpdating = True
Application.DisplayAlerts = True
sourceWorkbook.Close
MsgBox "全部文件拆分完成！"
End Sub
' 收集所有人员姓名
Sub CollectMethods(wb As Workbook, d As Object)
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
For Each ws In wb.Worksheets
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
For Each cell In ws.Range("A2:A" & lastRow)
If Not IsEmpty(cell.Value) Then
d(CleanFileName(Trim(cell.Value))) = 1
End If
Next
End If
Next
End Sub
' 处理工作表数据
Sub ProcessWorksheets(srcWb As Workbook, tgtWb As Workbook, person As String)
Dim ws As Worksheet
Dim newWs As Worksheet
Dim filterRange As Range
For Each ws In srcWb.Worksheets
With ws
If .AutoFilterMode Then .AutoFilterMode = False
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
.Range("A1:A" & lastRow).AutoFilter Field:=1, Criteria1:=person
Set filterRange = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
If Not filterRange Is Nothing Then
Set newWs = tgtWb.Worksheets.Add(After:=tgtWb.Worksheets(tgtWb.Worksheets.Count))
newWs.Name = GetUniqueSheetName(tgtWb, ws.Name)
.UsedRange.Copy newWs.Range("A1")
End If
.AutoFilterMode = False
End If
End With
Next
End Sub
' 生成唯一文件名
Function GenerateUniquePath(srcWb As Workbook, baseName As String, person As String, dateStr As String) As String
Dim counter As Long
Dim path As String
path = srcWb.Path & "\" & baseName & "_" & person & "_" & dateStr & ".xlsx"
While Len(Dir(path)) > 0
counter = counter + 1
path = srcWb.Path & "\" & baseName & "_" & person & "_" & dateStr & "(" & counter & ").xlsx"
Wend
GenerateUniquePath = path
End Function
' 清理非法字符
Function CleanFileName(text As String) As String
Dim illegalChars As String
illegalChars = "\/:*?""<>|"
Dim i As Integer
For i = 1 To Len(illegalChars)
text = Replace(text, Mid(illegalChars, i, 1), "_")
Next
CleanFileName = text
End Function
' 删除初始空白表
Sub RemoveInitialSheet(wb As Workbook)
While wb.Worksheets.Count > 1
Application.DisplayAlerts = False
wb.Worksheets(1).Delete
Application.DisplayAlerts = True
Wend
End Sub
' 获取唯一工作表名
Function GetUniqueSheetName(wb As Workbook, originalName As String) As String
Dim baseName As String
Dim counter As Long
baseName = Left(originalName, 27) ' 工作表名最大长度31字符
If Not WorksheetExists(wb, baseName) Then
GetUniqueSheetName = baseName
Exit Function
End If
Do
counter = counter + 1
While WorksheetExists(wb, baseName & "(" & counter & ")")
GetUniqueSheetName = baseName & "(" & counter & ")"
End Function
' 检查工作表是否存在
Function WorksheetExists(wb As Workbook, sheetName As String) As Boolean
On Error Resume Next
WorksheetExists = Not wb.Worksheets(sheetName) Is Nothing
On Error GoTo 0
End Function |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2025-3-13 15:44
