Macro genera archivo de solo lectura, sin razon alguna

[RadioViraje73]

Buenas,

Hay alguna razon por la cual cuando se ejecuta una Macro, se genere un archvio de solo lectura alterno al original? El codigo que uso es este:

Sub TrapasarTrimestre2() 'Leyendo cadena de texto

Dim Anio%, Trimes As Variant
Dim Conn As Object, rst As Object, SQL$
Dim Ruta$, Datos As Worksheet, RELACION As Worksheet, Rubro$, Tabla$, Campos$, RutaTriAnt$
Dim LibroDestino As Workbook, Z As Long, Condicion$, Cm%, Columnas As Variant, CamposRecord As Variant
Dim FIni As Date, FFinal As Date ', UltFila As Double
Dim HojaActual As Worksheet, Uf As Double, x As Long, y As Long
Dim LibroTriAnt As Workbook

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Volatile False
End With

Trimes = Val(Trim(InputBox("Esctiba el trimestre a procesar", "Trimestre")))
If Not IsNumeric(Trimes) Or Trimes < 1 Or Trimes > 4 Or Trimes = 0 Then MsgBox "La Opcion debe ser 1 A 4!!", 64, "Trimestres": Exit Sub

Set Conn = CreateObject("adodb.Connection")
Set rst = CreateObject("adodb.Recordset")
Set Datos = Sheets("DATOS")
Set RELACION = Sheets("RELACION")

Anio = Datos.Range("J6")

With Conn
  .Provider = "Microsoft.ACE.OLEDB.12.0"
  .Properties("Data Source") = ActiveWorkbook.FullName
  .Properties("Extended Properties") = "Excel 12.0 Xml;HDR=YES"
  .Open
End With

Ruta = Datos.Range("BP2") 'Actual
If Trim(Ruta) = Empty Then MsgBox "La ruta del archivo (Celda: BP2) del trimestre actual esta vacia!": Exit Sub
If Sifse.BuscarTexto(Ruta, Trimes & "T") = False Then MsgBox "Revisa que sea el archivo del " & Trimes & "T (Celda: BP2)!": Exit Sub

RutaTriAnt = Datos.Range("BQ2")
If Trimes <> 1 Then '***
    If Trim(RutaTriAnt) = Empty Then MsgBox "La ruta del archivo (Celda: BQ2) del trimestre anterior esta vacia!": Exit Sub
    If Sifse.BuscarTexto(RutaTriAnt, Trimes - 1 & "T") = False Then MsgBox "Revisa que sea el archivo del " & Trimes & "T (Celda: BQ2)!": Exit Sub
End If '***

Dim Pfi$, Pff$
Select Case Trimes
    Case 1: Pfi = "1/1": Pff = "31/3"
    Case 2: Pfi = "1/4": Pff = "30/6"
    Case 3: Pfi = "1/7": Pff = "30/9"
    Case 4: Pfi = "1/10": Pff = "31/12"
End Select

FIni = CDate(Pfi & "/" & Anio)
FFinal = CDate(Pff & "/" & Anio)

'-Abro el archivo
Set LibroDestino = Workbooks.Open(Ruta)
If Trimes <> 1 Then Set LibroTriAnt = Workbooks.Open(RutaTriAnt) '***

'Limpio el Libro Abierto
Workbooks(LibroDestino.Name).Activate

Dim i%, j%, FilD%, ColD%, SaldoAnt As Double, HojaA$ 'Saldoant: Saldo del libro del trime anterior, HojaA: Hoja del libro del libro del trime ant, FilD y Cold: Fila y col del libro y hoja Destino
Dim Q&, RutaBook$, RutaUtil$, Letra$, Filaformulas& 'Q: guarda el numero de columna
Dim FilT As Long, ColT As Long
Dim Tt As Single

Tt = Timer

With Workbooks(LibroDestino.Name)
    
    For i = 1 To Sheets.Count
        
        HojaA = Sheets(i).Name
        'Sheets(HojaA).Activate
        
        If Funciones.ExisteHoja(HojaA) = False Then MsgBox "La hoja: " & HojaA & "No exite", vbCritical: GoTo 1
        
        If Sheets(HojaA).Name = "EST SIT  FRA" Or Sheets(HojaA).Name = "TRABAJO" Then GoTo 1
        
        FilD = WorksheetFunction.Match("Fecha", Sheets(HojaA).Range("A:A"), 0)
        ColD = WorksheetFunction.Match("HABER", Sheets(HojaA).Range(FilD & ":" & FilD), 0)
        
        Filaformulas = Sheets(HojaA).Cells(Rows.Count, ColD).End(xlUp).Row
        
        If Filaformulas > 2000 Then Filaformulas = 290 'Si se pasa de las formulas que tome solo 290 filas
    
            If FilD = Empty Or FilD = 0 Or ColD = Empty Or ColD = 0 Then
                Set Datos = Nothing
                Set LibroDestino = Nothing
                Set RELACION = Nothing
                MsgBox "No existe Fecha, Debe en la Hoja " & HojaActual.Name, vbCritical, "Envio Trimestres"
                Exit Sub
            End If

        With Sheets(HojaA)
            .Range(.Cells(FilD + 1, 1), .Cells(Filaformulas - 1, ColD)) = "" 'Borra hasta donde esta la formula
            .Range(.Cells(FilD + 1, ColD + 1), .Cells(FilD + 1, ColD + 1)) = "" 'CelDa debajo de Saldo
        End With
        
        '------'Traemos los saldos-------Busco la fila y col de saldo
        If Trimes <> 1 Then '***
            Workbooks(LibroTriAnt.Name).Activate
            'Sheets(HojaA).Activate
        
            FilT = WorksheetFunction.Match("Fecha", Sheets(HojaA).Range("A:A"), 0)
            ColT = WorksheetFunction.Match("SALDO", Sheets(HojaA).Range(FilT & ":" & FilT), 0)
            
            Dim Ufila&
            Ufila = Sheets(HojaA).Cells(Rows.Count, 1).End(xlUp).Row '+ 1 '+1 Era para tomar la celda que seguia pero no toma el saldo xq la ultima celda debe sr la tiene datos
            
            'Si la fila y la col es = al texto SALDO---------
            If Not IsNumeric(Sheets(HojaA).Cells(Ufila, ColT).Value) Then
                SaldoAnt = Sheets(HojaA).Cells(Ufila + 1, ColT).Value '0
            Else
                SaldoAnt = Sheets(HojaA).Cells(Ufila, ColT).Value
            End If
            '-------
            Workbooks(LibroDestino.Name).Activate
            Workbooks(LibroDestino.Name).Sheets(HojaA).Cells(FilD + 1, ColD + 1) = SaldoAnt
        End If '***
1: Next i
'-----------
FilD = Empty: ColD = Empty: HojaA = Empty: Filaformulas = Empty
FilT = Empty: ColT = Empty

If Trimes <> 1 Then Workbooks(LibroTriAnt.Name).Close SaveChanges:=False '***

End With
End sub

Gracias de antemano.