北京
具：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.
體育大朋說
