时间戳

首页 > 解决方案 > 如果文件名重复，将文件移动到（错误）不同的目录

excel - 如果文件名重复，将文件移动到（错误）不同的目录

问题描述

我有一个代码，它根据第一行文本的内容重命名文本文件。

保存的文本文件的名称可以加倍。

我想将重复的文本文件保存在不同的目录“C:\Research syntheses - Meta analysis\Txt files ECS\out\double\”中。

Sub RenameTextFile()

    Const SpecialCharacters As String = "\,/,:,*,?,<,>,|,""," ' Modify this as neccesary
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim fso, MyFile, FileName, TextLine
    Dim char As Variant

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fol = fso.GetFolder("C:\Research syntheses - Meta analysis\Txt files ECS\out\")

     For Each fil In fol.Files

        FileName = fil

        Set MyFile = fso.OpenTextFile(FileName, ForReading)

        Do While MyFile.AtEndOfStream <> True

            Do
                Dim tmpLine As String
                TextLine = MyFile.ReadLine
                tmpLine = RemoveWhiteSpace(TextLine)
                If Len(tmpLine) = 0 Then
                    TextLine = tmpLine
                End If
            Loop Until Len(TextLine) > 0
            MyFile.Close

            For Each char In Split(SpecialCharacters, ",")
                TextLine = Replace(TextLine, char, "")
            Next

            fil.Name = TextLine & ".txt"
            Exit Do

        Loop

        MyFile.Close
    Next fil
End Sub

标签： excelvba

解决方案

Option Explicit

Sub RenameTextFile()
    Const SpecialCharacters As String = "\,/,:,*,?,<,>,|,""," ' Modify this as neccesary
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const foldPath As String = "C:\Research syntheses - Meta analysis\Txt files ECS\out\"
    Dim fso, MyFile, FileName, TextLine, fol As Object, fil As Object
    Dim char As Variant, arrSavedFiles(), k As Long, El As Variant, boolFound As Boolean

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fol = fso.GetFolder(foldPath)
    ReDim arrSavedFiles(k)

     For Each fil In fol.Files
        FileName = fil
        Set MyFile = fso.OpenTextFile(FileName, ForReading)
        Do While MyFile.AtEndOfStream <> True
            Do
                Dim tmpLine As String
                TextLine = MyFile.ReadLine
                tmpLine = Trim(TextLine)
                If Len(tmpLine) <> 0 Then
                    TextLine = tmpLine:  Exit Do
                End If
            Loop Until Len(TextLine) > 0
            MyFile.Close

            For Each char In Split(SpecialCharacters, ",")
                TextLine = Replace(TextLine, char, "")
            Next
            For Each El In arrSavedFiles
                If El = TextLine & ".txt" Then boolFound = True: Exit For
            Next
            If Not boolFound Then
                fil.Name = TextLine & ".txt"
                arrSavedFiles(k) = TextLine & ".txt"
                k = k + 1: ReDim Preserve arrSavedFiles(k)
            Else
                boolFound = False
                If Not fso.FolderExists(foldPath & "error\") Then MkDir foldPath & "error\"
                FileCopy foldPath & fil.Name, foldPath & "error\" & fil.Name
                Kill foldPath & fil.Name
            End If
            Exit Do
        Loop
        MyFile.Close
    Next fil
End Sub

这将做你需要的（我理解）。但是，如果有两个以上的文件包含相同的第一行 text，则必须以类似的方式调整代码。我的意思是，在将文件复制到“错误”文件夹之前，您必须填写另一个数组并检查该文件是否存在。并做一些事情（创建另一个文件夹，使用消息发出警告等）......移动的文件名不会改变！如有必要，可以在同一段代码中，或再次为“错误”文件夹运行代码。

推荐阅读