Macro para guardar en cualquier escritorio excel

Tengo esta macro para pasar una hoja a imagen, m me gustaría que me ayudaran a modificarla para poder guardar es imagen en cualquier escritorio ya que tengo el archivo en red

Sub CopiarCeldasComoImagen()
    'Copiar Celdas  como Imagen
    Application.ScreenUpdating = False
    Set h1 = Sheets("Vendedores")
    Set h2 = Sheets.Add
    'ruta = ThisWorkbook.Path & "\"
    ruta = "C:\Users\asistcontratos\Desktop\" & Range("A1") & Range("B1") & ""
    archivo = ruta & h1.[A1&" "&B1] & ".JPEG"
    '
    rango = "A1:Y63"
    '
    With h1.Range(rango)
        fi = .Cells(1, 1).Row
        ff = .Rows.Count + fi - 1
        ci = .Cells(1, 1).Column
        cf = .Columns.Count + ci - 1
        izq = .Cells(1, 1).Left
        der = h1.Cells(1, cf + 1).Left
        baj = .Cells(1, 1).Top
        arr = h1.Cells(ff + 1, 1).Top
        anc = der - izq
        alt = arr - baj
    End With
    '
    h1.Range(rango).CopyPicture
    h2.Shapes.AddChart
    With h2.ChartObjects(1)
        .Width = anc
        .Height = alt
        .Chart.Paste
        .Chart.Export archivo
        .Delete
    End With
    Application.DisplayAlerts = False
    h2.Delete
    Application.DisplayAlerts = True
    MsgBox "Celdas guardadas como imagen en el archivo: " & archivo, vbInformation, Date
End Sub

1 respuesta

Respuesta
1

Sustituye este código

    ruta = "C:\Users\asistcontratos\Desktop\" & Range("A1") & Range("B1") & ""

por este otro

mydesk = CreateObject("wscript.shell").specialfolders("desktop") & "\"

ruta =mydesk & Range("A1") & Range("B1") & ""

Vista http://programarexcel.com encontrarás cientos de macros para descargar

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas