Bom dia pessoal, o código abaixo consigo ler todos os arquivos de um diretório txt, mas quando eu peço para que ele faça a copia para uma novo de todos ele esta copiando um por cima do outro após o ajuste, poderiam me ajudar.

Por exemplo: diretório C:teste tenho dois arquivos chamado BD1, BD2

O código abaixo esta entrando em cada um fazendo os ajustes, isso já esta funcionando, mas ao efetuar a cópia ele copia da erro ele substitui um por cima do outro.

Sub SubstituirTeste()
        Dim Arquivo As String
        Dim Arquivo2 As String
        Dim Linha As String
        Dim Pasta As String
        Dim tempo As String
        Dim ANome As String
        
        tempo = Format(Time, "hhmmss")
        
        'Atribui a pasta onde estão os arquivos
        Pasta = "C:teste"
        
        'Coloca na variável o nome do primeiro arquivo
        Arquivo = Dir(Pasta & "*.txt")
        
        Do While Arquivo <> ""
        
        'Inicia um laço para cópia dos arquivos
        ANome = Pasta & Arquivo
       
        'Le o arquivo sem abrilo
        Arquivo = FreeFile
        
'        Arquivo = CInt(Arquivo) + 1
       
        'Define o local do arquivo editado. Pode ser alterado, caso queira que seja salvo em outro local.
        Arquivo2 = "C:" & "GKO" & tempo & (".txt")
       
        'Abre o arquivo que receberá os dados editados
        Open Arquivo2 For Output As #2
       
        'Abre o arquivo original
        Open ANome For Input As #1
       
        While Not EOF(1)
            Line Input #1, Linha
           
            'Substitui o caracter § por #
'            Linha = Replace(Linha, "§", "#")
            Linha = Replace(Linha, "IGUACU", "IGUAÇU")
            Linha = Replace(Linha, "GONCALO", "GONÇALO")
            Print #2, Linha
        Wend
        Close
        
        'Coloca na variável o nome do próximo arquivo
Arquivo = Dir
Loop

        MsgBox "Fim de Execução da Macro"
    End Sub