VBA代码问题：文本文件版本号无法持续递增及跨日期清理需求

问题原因 #

原代码逻辑存在错误：每次运行时会从版本1开始遍历，删除所有存在的当日版本文件，最后用遍历结束时的版本号创建新文件。第二次运行时会删除版本1文件，导致第三次运行时找不到版本1的文件，直接从版本1重新创建，出现版本号回退的情况。

修正后的代码 #

Sub UpdateTextFileWithVersion()
    Dim folderPath As String
    folderPath = "C:\Users\Desktop\SIM_macro\" ' 基础文件夹路径，不含日期前缀
    Dim currentDatePrefix As String
    currentDatePrefix = "Unsuppression_" & Format(Date, "dd.MM") & "_"
    
    ' 1. 删除前日所有Unsuppression格式文件
    Dim oldFile As String
    oldFile = Dir(folderPath & "Unsuppression_*.txt")
    Do While oldFile <> ""
        ' 判断文件是否属于当日，不属于则删除
        If Not Left(oldFile, Len(currentDatePrefix)) = currentDatePrefix Then
            Kill folderPath & oldFile
        End If
        oldFile = Dir()
    Loop
    
    ' 2. 找出当日已存在的最大版本号
    Dim maxVersion As Integer
    maxVersion = 0
    Dim currentFile As String
    currentFile = Dir(folderPath & currentDatePrefix & "*.txt")
    
    Do While currentFile <> ""
        ' 从文件名提取版本号
        Dim versionStr As String
        versionStr = Replace(currentFile, currentDatePrefix, "")
        versionStr = Left(versionStr, Len(versionStr) - 4) ' 移除.txt后缀
        
        If IsNumeric(versionStr) Then
            Dim currentVersion As Integer
            currentVersion = CInt(versionStr)
            If currentVersion > maxVersion Then
                maxVersion = currentVersion
            End If
        End If
        
        currentFile = Dir()
    Loop
    
    ' 3. 确定新版本号，并删除上一版本（如果存在）
    Dim newVersion As Integer
    newVersion = maxVersion + 1
    
    If maxVersion > 0 Then
        Dim oldVersionPath As String
        oldVersionPath = folderPath & currentDatePrefix & Format(maxVersion, "00") & ".txt"
        If Dir(oldVersionPath) <> "" Then
            Kill oldVersionPath
        End If
    End If
    
    ' 4. 复制指定单元格区域内容
    Dim copyRange As Range
    Set copyRange = ThisWorkbook.Sheets("Sheet1").Range("H2:H8")
    Dim valuesArray As Variant
    valuesArray = copyRange.Value
    
    ' 5. 创建新版本文件并写入内容
    Dim newFilePath As String
    newFilePath = folderPath & currentDatePrefix & Format(newVersion, "00") & ".txt"
    Dim fileNumber As Integer
    fileNumber = FreeFile
    
    Open newFilePath For Output As fileNumber
    Dim i As Integer
    For i = 1 To UBound(valuesArray, 1)
        Print #fileNumber, valuesArray(i, 1)
    Next i
    Close fileNumber
End Sub

代码说明 #

• 路径拆分：将基础文件夹路径与日期前缀分离，方便区分当日和前日文件
• 跨日期清理：遍历所有Unsuppression_*.txt文件，自动删除非当日的旧文件
• 版本号递增逻辑：通过遍历当日所有版本文件，提取最大版本号，确保新版本号正确递增
• 旧版本清理：仅删除当日的上一版本文件，而非所有历史版本，避免版本号回退
• 内容写入：保留原逻辑，将指定单元格区域内容写入新版本文件

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