• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

Téma: ulozit cast tabulky jako obrazek do slozky

Zaslal/a pospicek1983 23.11.2015 19:20

Dobrý den.
Měl bych na vás obrovskou prosbu zdali by jste mi nepomohly. Můj problém spočívá v tom že si nechám narýsovat obrazec max range je 210 sloupců a 175 řádků
v tomhle rozmezí se mi narýsuje obrazec a já bych potřeboval ten dany obrazec ulozit jako obrázek pomocí makra. Prosím o pomoc

Příloha: 28264_test-ukladani.rar (212kB, staženo 15x)

Zaslat odpověď >

---

tarantula222(23.11.2015 22:50)#028269

Napríklad takto?
...zmeň si cestu(teraz sa ukladá obrázok k .xlsm súboru) a oblasť ktorú chceš uložiť ako obrázok.

Příloha: 28269_test-ukladani.rar (210kB, staženo 15x)

citovat

tarantula222(24.11.2015 11:57)#028277

Macro som písal v noci a zabudol som na par "múch". Už sú opravené.
Určite sa to zíde viacerým vrátane mňa. Upravte si oblasť, cestu a názvy obrázkov.


Sub Ulozit_Ako_PNG()

Dim Graf As Chart
Dim NazObr As String, NazList As String, NazGra As String
Dim ObrH As Single, ObrW As Single
Dim Cesta As String, Nazov As String
Dim a As Byte, b As Byte

Application.ScreenUpdating = False

a = (99 - 1) * Rnd() + 1
b = (99 - 1) * Rnd() + 1
Nazov = "\Obrazok" & a & b 'nazov obrazku

NazList = ActiveSheet.Name
Cesta = Sheets(NazList).Parent.Path & Nazov & ".PNG" 'kam sa to ma ulozit
NazGra = "GrafX"

Selection.Copy 'oblast ktora sa ma ulozit
Sheets(NazList).Pictures.Paste.Select
NazObr = Selection.Name

With Selection
ObrH = .ShapeRange.Height
ObrW = .ShapeRange.Width
End With

Sheets(NazList).Cells(1, Columns.Count).Select
Set Graf = Charts.Add
Set Graf = Graf.Location(Where:=xlLocationAsObject, Name:=NazList)
With Graf
.Parent.Name = NazGra
.ChartArea.Width = ObrW
.ChartArea.Height = ObrH
.Parent.Border.LineStyle = 0
End With

Sheets(NazList).Shapes(NazObr).Copy

With Graf
.ChartArea.Select
.Paste
.Export Filename:=Cesta, FilterName:="PNG"
End With

With Sheets(NazList)
.ChartObjects(NazGra).Delete
.Shapes(NazObr).Delete
End With

Application.ScreenUpdating = True
End Sub
citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse