批量清除筛选条件保留下拉图标 & 清空固定区域

Option Explicit

'===========================================================
' 【可调参数区】按需修改
'===========================================================
Private Const TARGET_FOLDER As String = "D:\ExcelFiles\Data\"   ' ← 修改这里，末尾必须带 \
Private Const FILE_EXT As String = "*.xlsm"
Private Const PROCESS_SHEET_INDEX As Long = 1
Private Const HEADER_START_ROW As Long = 2
Private Const HEADER_START_COL As Long = 2
Private Const CLEAR_START_ROW As Long = 3
Private Const CLEAR_END_ROW As Long = 85
Private Const CLEAR_START_COL As Long = 5
Private Const CLEAR_END_COL As Long = 7
Private Const SHEET_PASSWORD As String = ""    '工作表保护密码，无密码留空

Public Sub BatchClearFilterKeepDropdown()
    Dim targetFolder As String
    Dim fileName As String
    Dim wb As Workbook
    Dim screenUpdatingState As Boolean
    Dim displayAlertsState As Boolean
    Dim enableEventsState As Boolean
    
    '保存原有设置
    screenUpdatingState = Application.ScreenUpdating
    displayAlertsState = Application.DisplayAlerts
    enableEventsState = Application.EnableEvents
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    targetFolder = TARGET_FOLDER
    
    '简单校验路径是否存在
    If Dir(targetFolder, vbDirectory) = "" Then
        MsgBox "文件夹不存在：" & targetFolder, vbCritical
        GoTo RestoreSettings
    End If
    
    fileName = Dir(targetFolder & FILE_EXT, vbNormal)
    
    Do While fileName <> ""
        Application.StatusBar = "Processing: " & fileName
        Set wb = Nothing
        
        On Error Resume Next
        Set wb = Workbooks.Open(Filename:=targetFolder & fileName, _
                                UpdateLinks:=0, _
                                ReadOnly:=False, _
                                IgnoreReadOnlyRecommended:=True)
        On Error GoTo 0
        
        If Not wb Is Nothing Then
            '检查工作表是否存在
            If PROCESS_SHEET_INDEX > wb.Sheets.Count Then
                MsgBox "文件 '" & fileName & "' 不存在第" & PROCESS_SHEET_INDEX & "工作表", vbExclamation
                wb.Close SaveChanges:=False
                Set wb = Nothing
                fileName = Dir
                GoTo ContinueLoop
            End If
            
            On Error GoTo FileErrorHandler
            '解除保护
            If SHEET_PASSWORD <> "" Then
                wb.Sheets(PROCESS_SHEET_INDEX).Unprotect Password:=SHEET_PASSWORD
            End If
            
            ClearFilterKeepIcon wb.Sheets(PROCESS_SHEET_INDEX)
            ClearTargetRange wb.Sheets(PROCESS_SHEET_INDEX), _
                              CLEAR_START_ROW, CLEAR_END_ROW, _
                              CLEAR_START_COL, CLEAR_END_COL
            
            wb.Save
            wb.Close SaveChanges:=False
            Set wb = Nothing
            On Error GoTo 0
            GoTo ContinueLoop
            
FileErrorHandler:
            MsgBox "文件【" & fileName & "】出错：" & Err.Description, vbCritical
            If Not wb Is Nothing Then
                wb.Close SaveChanges:=False
                Set wb = Nothing
            End If
            Err.Clear
            On Error GoTo 0
        Else
            MsgBox "无法打开文件：" & fileName, vbExclamation
        End If
        
ContinueLoop:
        fileName = Dir
    Loop
    
    Application.StatusBar = False
    MsgBox "全部文件处理完成！", vbInformation

RestoreSettings:
    '恢复Excel设置
    Application.ScreenUpdating = screenUpdatingState
    Application.DisplayAlerts = displayAlertsState
    Application.EnableEvents = enableEventsState
End Sub

'清除筛选条件，保留筛选下拉箭头
Private Sub ClearFilterKeepIcon(ws As Worksheet)
    Dim lastCol As Long
    Dim headerRange As Range
    
    lastCol = ws.Cells(HEADER_START_ROW, ws.Columns.Count).End(xlToLeft).Column
    If lastCol < HEADER_START_COL Then Exit Sub
    
    Set headerRange = ws.Range(ws.Cells(HEADER_START_ROW, HEADER_START_COL), _
                               ws.Cells(HEADER_START_ROW, lastCol))
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    headerRange.AutoFilter
End Sub

'清空指定区域内容（仅清除值，保留格式）
Private Sub ClearTargetRange(ws As Worksheet, rStart As Long, rEnd As Long, _
                             cStart As Long, cEnd As Long)
    Dim clearRng As Range
    Set clearRng = ws.Range(ws.Cells(rStart, cStart), ws.Cells(rEnd, cEnd))
    clearRng.ClearContents
End Sub