Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
A better way to browse. Learn more.
A full-screen app on your home screen with push notifications, badges and more.
Este tema está ahora archivado y está cerrado a más respuestas.
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.