Excel VBA代码扩展求助：非xlsx转格式+日期提取与排序

针对你的三个需求，我已经把原代码完全修改好了，直接替换你现有的ScanFiles子程序就能运行。下面是完整代码：

Sub ScanFiles()
    Dim myFile As String, path As String
    Dim erow As Long, col As Long
    Dim copyRange As Range, cel As Range
    Dim sourceWbk As Workbook, masterWbk As Workbook
    Dim foundCell As Range, dateStr As String, formattedDate As Date
    Dim lastRow As Long, sortRange As Range
    
    ' 设置文件夹路径
    path = "c:\Scanfiles\"
    myFile = Dir(path & "*.file")
    Set masterWbk = ThisWorkbook ' 主工作簿（当前运行代码的工作簿）
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False ' 关闭保存提示
    
    Do While myFile <> ""
        ' 1. 打开.file文件并另存为.xlsx格式
        Set sourceWbk = Workbooks.Open(path & myFile)
        Dim xlsxPath As String
        xlsxPath = path & Left(myFile, Len(myFile) - 5) & ".xlsx" ' 替换.file为.xlsx
        sourceWbk.SaveAs Filename:=xlsxPath, FileFormat:=xlOpenXMLWorkbook
        sourceWbk.Close savechanges:=False
        
        ' 打开转换后的.xlsx文件
        Set sourceWbk = Workbooks.Open(xlsxPath)
        
        ' 2. 提取指定数据：姓名姓氏（A18-D18、A19-D19）
        Set copyRange = sourceWbk.Sheets("sheet1").Range("A18:D18,A19:D19")
        
        ' 查找以"ended"开头的日期单元格
        Set foundCell = sourceWbk.Sheets("sheet1").Cells.Find( _
            What:="ended*", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        dateStr = ""
        If Not foundCell Is Nothing Then
            dateStr = Mid(foundCell.Value, 6) ' 提取"ended "后面的日期字符串（如20190808）
            ' 转换为日期格式并格式化月份为英文
            formattedDate = DateSerial(Left(dateStr, 4), Mid(dateStr, 5, 2), Right(dateStr, 2))
        End If
        
        ' 将数据写入主工作簿
        With masterWbk.Sheets("Sheet1")
            erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            col = 1
            For Each cel In copyRange
                .Cells(erow, col).Value = cel.Value
                col = col + 1
            Next
            ' 写入格式化后的日期（带英文月份）
            If dateStr <> "" Then
                .Cells(erow, col).Value = Format(formattedDate, "mmmm dd, yyyy") ' 格式如August 08, 2019
                .Cells(erow, col + 1).Value = formattedDate ' 隐藏列用于排序（可根据需要调整）
            End If
        End With
        
        ' 关闭文件
        sourceWbk.Close savechanges:=False
        ' 如果不需要保留转换后的.xlsx文件，可取消下面一行注释删除文件
        ' Kill xlsxPath
        
        myFile = Dir()
    Loop
    
    ' 3. 按日期从新到旧排序（使用隐藏的日期列排序）
    With masterWbk.Sheets("Sheet1")
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lastRow > 1 Then ' 有数据才排序
            Set sortRange = .Range("A1:" & .Cells(lastRow, .Columns.Count).End(xlToLeft).Address)
            sortRange.Sort Key1:=.Columns(9), Order1:=xlDescending, Header:=xlYes ' 假设日期在第9列，可根据实际调整
            ' 如果不需要隐藏列，排序后可删除该列
            ' .Columns(9).Delete
        End If
        .Range("A:E").EntireColumn.AutoFit
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "数据更新完成！", vbInformation
End Sub

对应需求的实现细节 #

1. .file格式自动转.xlsx #

• 把原代码中Dir(path & "*.xlsx")改为Dir(path & "*.file")，遍历所有.file文件
• 打开.file文件后，用SaveAs方法将其另存为.xlsx格式，保存路径和原文件一致，仅替换后缀
• 若不需要保留转换后的.xlsx文件，可取消代码中Kill xlsxPath的注释，自动删除临时文件

2. 提取三类指定数据 #

• 姓名姓氏部分保留原逻辑，直接提取A18:D18,A19:D19的内容
• 使用Find方法查找以"ended"开头的单元格，通过Mid(foundCell.Value, 6)提取后面的日期字符串（跳过"ended "的5个字符）
• 把提取的日期字符串（如20190808）转换为日期格式，再用Format函数转为带英文月份的格式（如August 08, 2019）

3. 按日期从新到旧排序 #

• 为保证排序准确性，代码额外写入原始日期值到隐藏列（默认第9列，可根据你的数据列数调整），以此作为排序依据
• 排序完成后，若不需要隐藏列，可取消.Columns(9).Delete的注释删除它
• 排序逻辑会自动判断是否有数据，避免空表报错

内容的提问来源于stack exchange，提问作者user12326522