WPS表格筛选后另存为多个工作簿

Sub WPS_按部门拆分工作簿_修复版()' 【关键修改】将 k 定义为 Variant，防止 WPS 报 "ByRef 参数类型不符"    Dim d As Object, k As Variant, arr, i As Long, lr As Long    Dim sht As Worksheet, newWb As Workbook, newSht As Worksheet    Dim path As String    Dim colDept As Integer    Dim deptName As String    Dim safeName As String    Dim rngVisible As Range    ' ================= 配置区域 =================    colDept = 3  ' 部门在 C 列，所以是 3    ' ===========================================    On Error GoTo ErrorHandler    Set d = CreateObject("scripting.dictionary")    Set sht = ActiveSheet    path = ThisWorkbook.path & "\"    If path = "\" Then        MsgBox "请先保存当前文件，然后再运行此宏！"        Exit Sub    End If    Application.ScreenUpdating = False    Application.DisplayAlerts = False    lr = sht.Cells(sht.Rows.Count, colDept).End(xlUp).Row    If lr < 2 Then        MsgBox "数据不足！"        GoTo CleanExit    End If    arr = sht.Range(sht.Cells(1, 1), sht.Cells(lr, sht.UsedRange.Columns.Count)).Value' 1. 收集部门    For i = 2 To lr        deptName = Trim(CStr(arr(i, colDept)))        If deptName <> "" Then            d(deptName) = ""        End If    Next    If d.Count = 0 Then        MsgBox "未找到部门名称！"        GoTo CleanExit    End If    ' 2. 循环拆分    For Each k In d.keys' k 现在是 Variant 类型，可以安全接收字典的 Key        safeName = ReplaceInvalidChars(CStr(k)) ' 强制转为字符串处理文件名        If Len(safeName) > 31 Then safeName = Left(safeName, 31)        If sht.AutoFilterMode Then sht.AutoFilterMode = False        sht.Range("A1").CurrentRegion.AutoFilter Field:=colDept, Criteria1:=k        Set newWb = Workbooks.Add(xlWBATWorksheet)        Set newSht = newWb.Sheets(1)' 复制标题        sht.Rows(1).Copy Destination:=newSht.Rows(1)        ' 复制可见数据        On Error Resume Next        Set rngVisible = sht.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible)        On Error GoTo ErrorHandler        If Not rngVisible Is Nothing Then            rngVisible.Copy Destination:=newSht.Rows(2)        End If        newSht.Columns.AutoFit        If Dir(path & safeName & ".xlsx") <> "" Then Kill path & safeName & ".xlsx"        newWb.SaveAs Filename:=path & safeName & ".xlsx", FileFormat:=xlOpenXMLWorkbook        newWb.Close SaveChanges:=False        Set rngVisible = Nothing        Set newSht = Nothing        Set newWb = Nothing    Next k    If sht.AutoFilterMode Then sht.AutoFilterMode = False    sht.ActivateCleanExit:    Application.ScreenUpdating = True    Application.DisplayAlerts = True    If Err.Number = 0 Then        MsgBox "? 拆分完成！共生成 " & d.Count & " 个文件。"    End If    Exit SubErrorHandler:    Application.ScreenUpdating = True    Application.DisplayAlerts = True    MsgBox "? 错误：" & Err.DescriptionEnd SubFunction ReplaceInvalidChars(strName As String) As String    Dim chars As Variant, c As Variant    chars = Array("/", "\", ":", "*", "?", "[", "]")    ReplaceInvalidChars = strName    For Each c In chars        ReplaceInvalidChars = Replace(ReplaceInvalidChars, c, "_")    Next c    ReplaceInvalidChars = Trim(ReplaceInvalidChars)End Function