北京
具：DEEPSEEK、或者百度DEEPSEEK满血版、腾讯元宝
提示词：将EXCEL工作表的数据进行拆分成多个文件并重新命名，按照第4列进行拆分,写出VBA代码，考虑兼容WPS
需要处理的表格如下图所示：
VBA代码：
Sub SplitByColumnD()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws As Worksheet
Dim dict As Object
Dim LastRow As Long, i As Long
Dim Key As Variant
Dim SavePath As String
Dim NewWB As Workbook
Dim FileDialog As FileDialog
Set ws = ActiveSheet
Set dict = CreateObject("Scripting.Dictionary")
' 获取保存路径
Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
FileDialog.Title = "选择保存位置"
If FileDialog.Show <> -1 Then Exit Sub
SavePath = FileDialog.SelectedItems(1) & "\"
' 获取唯一键值(第4列)
LastRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = 2 To LastRow
If Not IsEmpty(ws.Cells(i, 4)) Then
dict(ws.Cells(i, 4).Value) = 1
End If
Next i
' 遍历每个键值拆分数据
For Each Key In dict.Keys
' 应用筛选
ws.UsedRange.AutoFilter Field:=4, Criteria1:=Key
' 创建新工作簿
Set NewWB = Workbooks.Add
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy NewWB.Sheets(1).Range("A1")
' 清理格式
With NewWB.Sheets(1)
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells.PasteSpecial xlPasteFormats
.Cells(1, 1).Select
End With
Application.CutCopyMode = False
' 保存文件
Dim SafeName As String
SafeName = Replace(Key, "/", "-") ' 处理非法字符
SafeName = Replace(SafeName, "\", "-")
NewWB.SaveAs SavePath & SafeName & ".xlsx"
NewWB.Close False
Next Key
' 恢复设置
ws.AutoFilterMode = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "拆分完成！共生成 " & dict.Count & " 个文件", vbInformation
End Sub
操作步骤：鼠标依次单击“开发工具”——“Visual Basic”，然后会打开VB的编辑环境，鼠标再依次单击“插入”——“模块”，然后粘贴上方代码，并关闭VB编辑环境，最后，再单击“开发工具”——“宏”，在弹出的对话框，单击执行按钮。完成后的效果如下图所示。
特别声明：以上内容(如有图片或视频亦包括在内)为自媒体平台“网易号”用户上传并发布，本平台仅提供信息存储服务。
Notice: The content above (including the pictures and videos if any) is uploaded and posted by a user of NetEase Hao, which is a social media platform and only provides information storage services.
