Copiar formato de filas.

publicado el 20 de mayo12 años

Buenos días estimados, estoy lidiando con un tema que no encuentro ayuda en ningún lado.

El problema es así, en un libro de excel se le agregó dos filas con campos dinámicos de datos. Antes de que se le agreguen estos campos, el libro funcionaba bien, generaba una copia de una de las hojas en una hoja nueva y copiaba bien todo ahora no copia el alto de las filas, sale todo en tamaño normal.

La verdad que ya no se que hacer para resolver este problema.

El código que genera este informe es el siguiente:

Option Explicit

Sub genDefinitivo()

' Macro3 Macro

' Macro grabada el 28/10/2008 por dapezteguia

Dim tArchOrig As String, tArchDes As String, tArchDefinitivo As String

Application.SheetsInNewWorkbook = 2

VerArchDefinitivo

tArchDefinitivo = Range("AI101").Value

tArchOrig = ActiveWindow.Caption

Workbooks.Add

tArchDes = ActiveWindow.Caption

Windows(tArchOrig).Activate

Sheets("GRAL").Select

Cells.Select

Range("D1").Activate

Selection.Copy

Windows(tArchDes).Activate

Cells.Select

ActiveSheet.Paste

ActiveWindow.SmallScroll Down:=-6

Windows(tArchOrig).Activate

Range("E19:U37").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("E19:U37").Select

ActiveWindow.ScrollColumn = 4

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

ActiveWindow.ScrollColumn = 5

ActiveWindow.ScrollColumn = 6

ActiveWindow.ScrollColumn = 7

ActiveWindow.ScrollColumn = 6

ActiveWindow.ScrollColumn = 5

ActiveWindow.ScrollColumn = 4

Windows(tArchOrig).Activate

Range("E43:U43").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("E43").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("T48").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("T48").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("T50").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("T50").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("F53:T57").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("F53").Select

' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

' :=False, Transpose:=False

Windows(tArchOrig).Activate

Range("O59").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("O59").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("D61").Select

ActiveWindow.SmallScroll Down:=12

Rows("75:75").Select

Range("D75").Activate

ActiveWindow.SmallScroll Down:=29

Range(Selection, Selection.End(xlDown)).Select

Rows("75:116").Select

Range("D75").Activate

Application.CutCopyMode = False

Selection.Delete Shift:=xlUp

Windows(tArchOrig).Activate

Sheets("PODER_RESCATE").Select

Cells.Select

Range("C1").Activate

Selection.Copy

Windows(tArchDes).Activate

Sheets("Hoja2").Select

Cells.Select

ActiveSheet.Paste

Windows(tArchOrig).Activate

Range("D14:L37").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("D14").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Rows("40:244").Select

Range("C40").Activate

Sheets("Hoja2").Select

Sheets("Hoja2").Name = "Poder rescate"

Sheets("Hoja1").Select

Sheets("Hoja1").Name = "GRAL"

Range("E56").Select

Windows(tArchDes).Activate

Sheets("Poder rescate").Select

'Se cambio el 60 por el 62: Limite de lineas

Range("C62:IV982").Select

Application.CutCopyMode = False

Selection.ClearContents

'Se cambio el 60 por el 62: Limite de lineas

Rows("62:502").Select

Range("C62").Activate

Selection.Delete Shift:=xlUp

Range("R1:IV982").Select

Application.CutCopyMode = False

Selection.ClearContents

Windows(tArchDes).Activate

Sheets("GRAL").Select

Range("D75:IV982").Select

Application.CutCopyMode = False

Selection.ClearContents

Range("AA:IV").Select

Application.CutCopyMode = False

Selection.ClearContents

With ActiveSheet.PageSetup

.LeftHeader = ""

.CenterHeader = ""

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

.LeftMargin = Application.InchesToPoints(0)

.RightMargin = Application.InchesToPoints(0)

.TopMargin = Application.InchesToPoints(0)

.BottomMargin = Application.InchesToPoints(0)

.HeaderMargin = Application.InchesToPoints(0)

.FooterMargin = Application.InchesToPoints(0)

.PrintHeadings = False

.PrintGridlines = False

.PrintComments = xlPrintNoComments

'.PrintQuality = 600

.CenterHorizontally = False

.CenterVertically = False

.Orientation = xlLandscape

.Draft = False

.PaperSize = xlPaperA4

.FirstPageNumber = xlAutomatic

.Order = xlDownThenOver

.BlackAndWhite = False

.Zoom = False

.FitToPagesWide = 1

.FitToPagesTall = 1

End With

Windows(tArchDes).Activate

Sheets("Poder rescate").Select

With ActiveSheet.PageSetup

.LeftHeader = ""

.CenterHeader = ""

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

.LeftMargin = Application.InchesToPoints(0)

.RightMargin = Application.InchesToPoints(0)

.TopMargin = Application.InchesToPoints(0)

.BottomMargin = Application.InchesToPoints(0)

.HeaderMargin = Application.InchesToPoints(0)

.FooterMargin = Application.InchesToPoints(0)

.PrintHeadings = False

.PrintGridlines = False

.PrintComments = xlPrintNoComments

'.PrintQuality = 600

.CenterHorizontally = False

.CenterVertically = False

.Orientation = xlLandscape

.Draft = False

.PaperSize = xlPaperA4

.FirstPageNumber = xlAutomatic

.Order = xlDownThenOver

.BlackAndWhite = False

.Zoom = False

.FitToPagesWide = 1

.FitToPagesTall = 1

End With

Range("C4").Activate

Sheets("GRAL").Select

Range("D12").Activate

'ChDir "\\Cpmtecnologia\Tecnologia\Desarrollo\CierreMesas\Arqueo\2008_08\Definitivos"

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:= _

tArchDefinitivo _

, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _

ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWindow.Close

Application.DisplayAlerts = True

Windows(tArchOrig).Activate

Sheets("PODER_RESCATE").Select

Range("D1").Activate

Sheets("GRAL").Select

Range("D1").Activate

End Sub

Sub genAdministracion()

' Macro3 Macro

' Macro grabada el 28/10/2008 por dapezteguia

Dim tArchOrig As String, tArchDes As String, tArchDefinitivo As String

Application.SheetsInNewWorkbook = 1

VerArchAdministracion

tArchDefinitivo = Range("AI101").Value

tArchOrig = ActiveWindow.Caption

Workbooks.Add

tArchDes = ActiveWindow.Caption

Windows(tArchOrig).Activate

Sheets("GRAL").Select

Cells.Select

Range("D1").Activate

Selection.Copy

Windows(tArchDes).Activate

Cells.Select

ActiveSheet.Paste

ActiveWindow.SmallScroll Down:=-6

Windows(tArchOrig).Activate

Range("E19:U37").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("E19:U37").Select

ActiveWindow.ScrollColumn = 4

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

ActiveWindow.ScrollColumn = 5

ActiveWindow.ScrollColumn = 6

ActiveWindow.ScrollColumn = 7

ActiveWindow.ScrollColumn = 6

ActiveWindow.ScrollColumn = 5

ActiveWindow.ScrollColumn = 4

Windows(tArchOrig).Activate

Range("S68:U68").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("S68").Select

ActiveWindow.ScrollColumn = 4

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("E43:U43").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("E43").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("T48").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("T48").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("F52:O64").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("F52").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Windows(tArchOrig).Activate

Range("O57").Select

Application.CutCopyMode = False

Selection.Copy

Windows(tArchDes).Activate

Range("O57").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("D59").Select

ActiveWindow.SmallScroll Down:=12

Rows("73:73").Select

Range("D73").Activate

ActiveWindow.SmallScroll Down:=29

Range(Selection, Selection.End(xlDown)).Select

Rows("73:116").Select

Range("D73").Activate

Application.CutCopyMode = False

Selection.Delete Shift:=xlUp

Sheets("Hoja1").Select

Sheets("Hoja1").Name = "GRAL"

Range("E56").Select

Windows(tArchDes).Activate

Sheets("GRAL").Select

Range("D75:IV982").Select

Application.CutCopyMode = False

Selection.ClearContents

Range("AA:IV").Select

Application.CutCopyMode = False

Selection.ClearContents

Rows("19:35").Select

Range("D19").Activate

Selection.Delete Shift:=xlUp

Range("R33").Select

ActiveWindow.ScrollColumn = 5

ActiveWindow.ScrollColumn = 6

ActiveWindow.ScrollColumn = 7

Range("N33").Select

Selection.Copy

Range("R33:T33").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Selection.ClearContents

Selection.ClearComments

' Windows(tArchOrig).Activate

' Range("R63:U74").Select

' Selection.Copy

' Windows(tArchDes).Activate

' Range("R46").Select

' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

' :=False, Transpose:=False

' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _

' :=False, Transpose:=False

Windows(tArchOrig).Activate

Range("D46:AA46").Select

Selection.Copy

Windows(tArchDes).Activate

Range("D29").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

With ActiveSheet.PageSetup

.LeftHeader = ""

.CenterHeader = ""

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

.LeftMargin = Application.InchesToPoints(0)

.RightMargin = Application.InchesToPoints(0)

.TopMargin = Application.InchesToPoints(0)

.BottomMargin = Application.InchesToPoints(0)

.HeaderMargin = Application.InchesToPoints(0)

.FooterMargin = Application.InchesToPoints(0)

.PrintHeadings = False

.PrintGridlines = False

.PrintComments = xlPrintNoComments

' .PrintQuality = 600

.CenterHorizontally = False

.CenterVertically = False

.Orientation = xlLandscape

.Draft = False

.PaperSize = xlPaperA4

.FirstPageNumber = xlAutomatic

.Order = xlDownThenOver

.BlackAndWhite = False

.Zoom = False

.FitToPagesWide = 1

.FitToPagesTall = 1

End With

Sheets("GRAL").Select

Range("D12").Activate

'ChDir "\\Cpmtecnologia\Tecnologia\Desarrollo\CierreMesas\Arqueo\2008_08\Definitivos"

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:= _

tArchDefinitivo _

, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _

ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWindow.Close

Application.DisplayAlerts = True

Windows(tArchOrig).Activate

Sheets("PODER_RESCATE").Select

Range("D1").Activate

Sheets("GRAL").Select

Range("D1").Activate

End Sub

Gracias a todos por destinar tiempo en mi consulta.

Saludos cordiales.

formato (2).txt

publicado el 20 de mayo12 años

Hola Maret, creo que tu problema puede estar en esta parte:

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,

Con eso tu estas copiando y pegando valores únicamente, lo que no modifica el formato del destino donde estás pegando. Dices que antes si funcionaba? Puedes adjuntar tu archivo para revisarlo?

publicado el 20 de mayo12 años

Autor

Hola Maret, creo que tu problema puede estar en esta parte:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,

Con eso tu estas copiando y pegando valores únicamente, lo que no modifica el formato del destino donde estás pegando. Dices que antes si funcionaba? Puedes adjuntar tu archivo para revisarlo?

Hola Smako, muchas gracias por tu respuesta. Te comento que yo intente cambiar xlPasteValues por xlPasteFormats y no me funciona tampoco.

El libro 1 es el que anda bien.

El libro 2 no. Se le agrego el modulo 7 y en la hoja PODER_RESCATE se le agrego las dos lineas y campos que van desde la celda C37 hasta L39.

El modulo 5 es el que copia estos valores y genera el archivo definitivo. Y este es donde tengo el problema.

Te comento que es un archivo en red, que funciona dependiendo de otros archivos, seguramente te va a tirar un problema de conexion, lo omites y recien ahí vas a poder ver el archivo sin algunas funciones, pero vas a poder ver el código.

Te adjunto el libro y desde ya muchísimas gracias por tu gran ayuda. Ojala me puedas ayudar a resolver este gran problema que tengo.

No me deja adjuntar la página, pero te dejo el libro en google Drive:

https://docs.google.com/file/d/0B8hnsr9iLJJ7cmJBOHJic29ISFU/edit?usp=sharing

Ojala lo puedas ver, decime cualquier cosa. Y nuevamente mil gracias.

publicado el 20 de mayo12 años

Aparentemente la hoja que usas para copiar tiene algún problema que posiblemente se solucione volviendola a crear. Se lo molesto que puede ser eso, por lo que te dejo otra opción, pruebalo y me dices si te sirve: Download libro2 modificado.zip from Sendspace.com - send big files the easy way es tu mismo archivo, solo arreglé la parte en la que tenías problemas

publicado el 20 de mayo12 años

Autor

Aparentemente la hoja que usas para copiar tiene algún problema que posiblemente se solucione volviendola a crear. Se lo molesto que puede ser eso, por lo que te dejo otra opción, pruebalo y me dices si te sirve: Download libro2 modificado.zip from Sendspace.com - send big files the easy way es tu mismo archivo, solo arreglé la parte en la que tenías problemas

Hola, muchas gracias!!! te hago una consulta, el modulo que creaste afecta bien a una de las hojas. Pero el archivo genera dos, una se llama hoja1 (GRAL) y la otra se llama hoja2(PODER_RESCATE).

Como puedo modificarlo para que me afecte a las dos? O que debería hacer?

Mil gracias por tu excelente ayuda!!! no sé como agradecerte ya!

publicado el 21 de mayo12 años

Listo Marte, aqui lo tienes Download Libro 2 modificado.zip from Sendspace.com - send big files the easy way, avisame si necesitas algo mas

publicado el 23 de mayo12 años

Autor

Hola Smako! mil gracias, sos un genio!!! no quiero abusar de amabilidad, pero a lo mejor me puedes dar una idea. El archivo anda perfecto en mi PC y en otra, pero en otras dos NO, la solapa de PENDIENTE debe tomar un archivo en red y al apretar actualizar en las dos PCS no patchea la dirección. Tenes idea si le puede faltar algun archivo en particular a la PC, como ser un parche o algo así para que funcione?

Nuevamente gracias por la gran ayuda que me has dado. Por otro lado, hay alguna manera de que pueda agradecerte todo lo que em ayudaste?

Abrazo!

publicado el 23 de mayo12 años

Hola Smako! mil gracias, sos un genio!!! no quiero abusar de amabilidad, pero a lo mejor me puedes dar una idea. El archivo anda perfecto en mi PC y en otra, pero en otras dos NO, la solapa de PENDIENTE debe tomar un archivo en red y al apretar actualizar en las dos PCS no patchea la dirección. Tenes idea si le puede faltar algun archivo en particular a la PC, como ser un parche o algo así para que funcione?
Nuevamente gracias por la gran ayuda que me has dado. Por otro lado, hay alguna manera de que pueda agradecerte todo lo que em ayudaste?

Abrazo!

Buen día Maret, creo que tendrías que verificar que estén habilitadas las macros en las 2 PC y que no tengan ningún problema de acceso a la red, en específico a la dirección de donde se obtiene la información para el archivo. Al ser un problema local ya es un poco mas complejo ayudarte, pero en lo que pueda aquí estoy. Y de lo demás, no te preocupes que con las gracias y la satisfacción de saber que te ayude es suficiente.

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas

Domina Excel, de Cero a Experto

¿Atascado? Deja de buscar soluciones puntuales. Aprende a dominar Excel para siempre con nuestro curso online. Más de 115 lecciones y soporte directo.

Ver el Curso Completo

194 Archivos
100 Comentarios
30 Revisiones
Última descarga

Nuevo mapa de municipios españoles
- 3

Saludos

Esta es la primera vez que veo un foro pago, pero me da esperanzas de que aprenderé mucho aquí.

Por fernandoflr, · publicado el domingo a las 20:214 días
Crear un loop para emitir recibos

Por Corvette, · publicado el sábado a las 04:215 días
Crear un loop para emitir recibos

Hola! anoche estuve revisando, tuve que hacer unos pequeños ajustes en la direccion de la carpeta (en vez de poner la direccion en partes la coloque toda de corrido parecida a como estaba antes) y logramos (vos y yo) que funcione!. Tambien tuve que desactivar la linea de código que bloqueaba la hoja porque sino no estaba dejando que la macro escriba el codigo de la propiedad en la celda, pero eso es lo de menos, supongo que lo puedo solucionar poniendo el bloqueo al final de la macro que creaste o desprotegiendo la celda donde se pone el codigo de propiedad.
Así que doy por supuesto que eso lo voy a poder hacer funcionar por lo que entonces voy a marcar como que ya está solucionado lo que necesitaba.
Agradezco muchisimo tu ayuda porque era sumamente tedioso tener que estar haciendo los recibos de a uno ya que la macro de envio de recibos es medio lenta. Ahora no me importa si tarda mucho, apretaré el boton y le daré todo el tiempo que se quiera tomar mientras yo hago otra cosa.
Gracias nuevamente!!!!

Por Corvette, · publicado el 9 de diciembre9 dic
Crear un loop para emitir recibos

Prueba con tu código modificado

Por JSDJSD, · publicado el 5 de diciembre5 dic
Crear un loop para emitir recibos

Sub Imagen13_Haga_clic_en() Dim Izq As Single, Arr As Single, Ancho As Single, Alto As Single Dim rutaArchivo As String Dim Email As CDO.Message Dim t As Single Application.DisplayAlerts = False Application.ScreenUpdating = False ActiveSheet.Unprotect "4324" '--- GENERAR IMAGEN DEL RECIBO --- With Range("H7:R34") Izq = .Left: Arr = .Top: Ancho = .Width: Alto = .Height .CopyPicture End With With ActiveSheet.ChartObjects.Add(Izq, Arr, Ancho, Alto) .Activate .Chart.Paste '---- RUTA DEL ARCHIVO (CORREGIDO) ---- rutaArchivo = "C:\Users\Usuario\Google Drive\LOCACIONES\REC. PROPIETARIOS\" & _ Format(Range("Q20"), "mmmYY") & " - " & _ Range("Q9") & " - " & _ Range("P17") & " - " & _ Range("K19") & ".JPG" .Chart.Export rutaArchivo .Delete End With 'Guardar ruta en AK30 por compatibilidad Range("AK30").Value = rutaArchivo '--- PEGAR BLOQUE DE DATOS --- Range("AH6").Copy Range("AH9").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Range("Y7:AI33").Copy Range("H7").PasteSpecial xlPasteAll ActiveSheet.Protect "4324" ActiveWorkbook.Save '--- PREPARAR ENVÍO DEL MAIL --- Set Email = New CDO.Message correo_origen = "nqn.negocios@gmail.com" Clave_correo_origen = "wkfhaapcnjljbwju" correo_destino = Range("AK27").Value Asunto = Range("AK28") Mensaje = Range("AK29") Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com" Email.Configuration.Fields(cdoSendUsingMethod) = 2 With Email.Configuration.Fields .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = correo_origen .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Clave_correo_origen .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True End With '--- VALIDAR ARCHIVO ANTES DE ENVIAR --- t = Timer Do While Dir(rutaArchivo) = "" And Timer - t < 5 DoEvents Loop If Dir(rutaArchivo) = "" Then MsgBox "ERROR: El archivo no se generó: " & rutaArchivo, vbCritical Exit Sub End If '--- ENVIAR MAIL --- With Email .To = correo_destino .From = correo_origen .Subject = Asunto .TextBody = Mensaje .Configuration.Fields.Update .AddAttachment rutaArchivo On Error Resume Next .Send End With End Sub Sub powerbuttonINQ() Dim Izq As Single, Arr As Single, Ancho As Single, Alto As Single Dim rutaArchivo As String Dim Email As CDO.Message Dim t As Single Application.DisplayAlerts = False Application.ScreenUpdating = False ActiveSheet.Unprotect "4324" '--- GENERAR IMAGEN DEL RECIBO --- With Range("H7:R33") Izq = .Left: Arr = .Top: Ancho = .Width: Alto = .Height .CopyPicture End With With ActiveSheet.ChartObjects.Add(Izq, Arr, Ancho, Alto) .Activate .Chart.Paste rutaArchivo = "C:\Users\Usuario\Google Drive\LOCACIONES\REC. INQUILINOS\" & _ Format(Range("Q20"), "mmmYY") & " - " & _ Range("Q9") & " - " & _ Range("P17") & " - " & _ Range("J17") & ".JPG" .Chart.Export rutaArchivo .Delete End With Range("AK30").Value = rutaArchivo Range("AH6").Copy Range("AH9").PasteSpecial Paste:=xlPasteValuesAndNumberFormats Range("Y7:AI33").Copy Range("H7").PasteSpecial xlPasteAll ActiveSheet.Protect "4324" ActiveWorkbook.Save '--- EMAIL CONFIG --- Set Email = New CDO.Message correo_origen = "nqn.negocios@gmail.com" Clave_correo_origen = "wkfhaapcnjljbwju" correo_destino = Range("AK27").Value Asunto = Range("AK28") Mensaje = Range("AK29") Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com" Email.Configuration.Fields(cdoSendUsingMethod) = 2 With Email.Configuration.Fields .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = correo_origen .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Clave_correo_origen .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True End With '--- VERIFICAR ARCHIVO --- t = Timer Do While Dir(rutaArchivo) = "" And Timer - t < 5 DoEvents Loop If Dir(rutaArchivo) = "" Then MsgBox "ERROR: El archivo no se generó: " & rutaArchivo, vbCritical Exit Sub End If '--- ENVIAR --- With Email .To = correo_destino .From = correo_origen .Subject = Asunto .TextBody = Mensaje .Configuration.Fields.Update .AddAttachment rutaArchivo On Error Resume Next .Send End With End Sub

Por JSDJSD, · publicado el 5 de diciembre5 dic

No hay usuarios registrado para ver esta página.

Conéctate a Ayuda Excel

Copiar formato de filas.

Featured Replies

Archivado

Archivos

Nuevo mapa de municipios españoles

Agenda Calendario Vintage

Cómo conservar la función AHORA()

Agenda v01

Gráficos de aranceles con colores difusos

Estadísticas de descargas

Mensajes

Saludos

Crear un loop para emitir recibos

Crear un loop para emitir recibos

Crear un loop para emitir recibos

Crear un loop para emitir recibos

Visualizado recientemente 0

Account

Navigation

Buscar

Configure browser push notifications

Chrome (Android)

Chrome (Desktop)

Safari (iOS 16.4+)

Safari (macOS)

Edge (Android)

Edge (Desktop)

Firefox (Android)

Firefox (Desktop)