export listu v Excelu Vyřešeno

[m.niki]

Dobrý den, potřeboval bych poradit, jak uložit jeden samostatný list ze sešitu do nového sešitu tak, aby se zkopírovali pouze hodnoty buněk a kompletní formátování, obrázky apod. prostě aby ten nový list vypadal uplně stejně jako zdroj, ale nebyl závislý na listech v původním sešitě. List který chci exportovaj je tvořen výpočty, vzorci a formátováním v závislosti na ostatních listech. Zkoušel jsem kopírovat a následně vložit jinak, ale to je zdlouhavé a je zde velká možonost chyb (potřebuji takto ukládat spoustu souborů denně). Asi bych potřeboval makro, ve kterém bych zvolil, jak má nový sešit pojmenovat a kam jej uložit, a následně vybrat list, který se má takto exportovat. Nevíte někdo o návosu který řeši podobnou problematiku? děkuji moc za rady.

[Reklama]

[navstevnik]

Protoze neni uvedeno nic blizsiho o zpusobu pouzivani, je nize procedura, ktrerou vloz do sesitu, ze ktereho ma byt kopirovano (v editoru VBA do standardniho modulu, volat klavesovou zkratkou; lze vlozit i do osobniho sesitu maker).
Po spusteni je vyzadano vlozeni diskove jednotky, cesty a nazvu ciloveho souboru, aktivni list je prekopirovan do noveho sesitu a vlozeny hodnoty.

Kód: Vybrat vše

Option Explicit

Sub KopirovatHodnotyFormat()
' zkopiruje aktivni list v aktivnim sesitu do noveho sesitu - format a hodnoty,
' ulozi a pojmenuje dle zadani
  Dim SWsht As Worksheet, PathFile As String
  Dim TWbk As Workbook
  ' vlozeni cesty a nazvu ciloveho souboru
  PathFile = Application.InputBox("Zadej disk, cestu a nazev ciloveho souboru" & vbCr & vbCr _
      & "Disk:\adresar\nazev.xls", Type:=2)
  If PathFile = "False" Then Exit Sub  ' storno vraci "False"
  Set SWsht = ActiveWorkbook.ActiveSheet  ' aktivni list
  SWsht.Copy  ' kopirovat list do noveho sesitu
  On Error Resume Next
  ActiveWorkbook.SaveAs PathFile  'ulozit do adresare pod zadanym jmenem
  If Err.Number <> 0 Then
    MsgBox "Chybne zadani ciloveho souboru"
    ActiveWorkbook.Close False
    GoTo Err1
  End If
  On Error GoTo 0
  Set TWbk = ActiveWorkbook
  ' vlozit hodnoty
  With TWbk
    With .ActiveSheet
      .Range(.UsedRange.Address).Value = .UsedRange.Value
    End With
    .Close True  ' zavrit cilovy sesit
  End With
  Set TWbk = Nothing
Err1:
  Set SWsht = Nothing
End Sub

Otestuj, zda splnuje pozadovane, nemam k dispozici vhodny soubor .

[m.niki]

funguje to, ještě bych měl jednu prosbičku, když bych chtěl, aby se soubor ukládal do stejného adresáře jako výchozí, a jako název měl spojení slova "objednávka" + hodnoty buňky A6, např. tedy faktura789.xls, jak bude vypadat kód? můžeš mi kdyžtak poradit nějaké stránky věnující se této problematice, abych mohl tvůj kód rozluštit, pochopit a postupně zkoušet upravovat. děkuji moc za rychlou reakci a pěkné řešení původního dotazu

[navstevnik]

Uvadis:

měl spojení slova "objednávka" + hodnoty buňky A6, např. tedy faktura789.xls

neni jasne, co je v bunce A6 a kde je tedy slovo objednavka, kdyz vysledny nazev ma byt faktura789.xls.

V priloze je upravena procedura, na radku:

Kód: Vybrat vše

  ' sestaveni cesty a nazvu ciloveho souboru
  PathFile = Application.ActiveWorkbook.Path & "\" & "objednavka" & SWsht.Range("a6").Value & ".xls"

si poskladej potrebny nazev, v prvni casti je cesta a adresar vychoziho souboru a obsah bunky A6 - SWsht.Range("a6").Value - uprav dle potreby.

Kód: Vybrat vše

Option Explicit

Sub KopirovatHodnotyFormat()
' zkopiruje aktivni list v aktivnim sesitu do noveho sesitu - format a hodnoty,
' ulozi a pojmenuje dle zadani
  Dim SWsht As Worksheet, PathFile As String
  Dim TWbk As Workbook

  Set SWsht = ActiveWorkbook.ActiveSheet  ' aktivni list
  ' sestaveni cesty a nazvu ciloveho souboru
  PathFile = Application.ActiveWorkbook.Path & "\" & "objednavka" & SWsht.Range("a6").Value & ".xls"
  SWsht.Copy  ' kopirovat list do noveho sesitu
  On Error Resume Next
  ActiveWorkbook.SaveAs PathFile  'ulozit do adresare pod zadanym jmenem
  If Err.Number <> 0 Then
    MsgBox "Chybne zadani ciloveho souboru"
    ActiveWorkbook.Close False
    GoTo Err1
  End If
  On Error GoTo 0
  Set TWbk = ActiveWorkbook
  ' vlozit hodnoty
  With TWbk
    With .ActiveSheet
      .Range(.UsedRange.Address).Value = .UsedRange.Value
    End With
    .Close True  ' zavrit cilovy sesit
  End With
  Set TWbk = Nothing
Err1:
  Set SWsht = Nothing
End Sub

Literatury je na webu nepreberne mnozstvi, mozna na zacatek koukni na http://www.officir.ic.cz/excelentne.html

[m.niki]

omlouvám se za překlep - lítám mezi objednávkama a fakturama, tak se mi to popletlo, výsledek jedy objednávka789.xls

děkuji moc za ochotu, funguje to perfektně

// Příspěvky sloučeny.
// Pokud chceš něco dodat a ještě nikdo po tobě nepřispěl, použij tlačítko >> Upravit << a svůj příspěvek doplň. Díky.
//mike007