Excel - makro na uložení sešitu Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

kulda_5
nováček
Příspěvky: 2
Registrován: červen 20
Pohlaví: Muž
Stav:
Offline

Re: Excel - makro na uložení sešitu

Příspěvekod kulda_5 » 02 čer 2020 14:12

Dobrý den,

mám problém. Mám cca 30 listů v excelu a potřeboval bych je uložit do pdf. každý zvlášť a pojmenovat podle názvu listu nebo bunky "CC1" ( mají stejný název to je jedno)

Nemohl by mi někdo poradit ?

Sub Makro1()
'
' Makro1 Makro
'
a = Range("CC1").Text
soubor = "C:\Users\uid40697\Desktop\Action corner_makro\test\" & a & ".pdf"


ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
soubor, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False


'
End Sub

tohle mi píše že soubor není uložen. Přitom je přímo ve stejném adresáři.

Reklama
Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Excel - makro na uložení sešitu

Příspěvekod elninoslov » 02 čer 2020 22:30

Problémom je zapisovanie do systémového adresára na systémovom disku. Ak to dáte na iný disk ide to OK. Máte právo zapisovať tomu užívateľovi na plochu?

Kód: Vybrat vše

Sub ExportListsToSeparatedPDFs()
Dim WS As Worksheet, Path As String

    Path = "D:\Users\uid40697\Desktop\Action corner_makro\test\"
    For Each WS In ThisWorkbook.Worksheets
        WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & WS.Name & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Next WS
    Set WS = Nothing
End Sub

kulda_5
nováček
Příspěvky: 2
Registrován: červen 20
Pohlaví: Muž
Stav:
Offline

Re: Excel - makro na uložení sešitu

Příspěvekod kulda_5 » 03 čer 2020 08:48

Práva k zápisu mám.... Jsem Administrátor.

prepsal jsme to tedy na disk D:\ podle vašeho skriptu, ale buhužel stále nefunguje.

Chyba Run-time error '1004':

Dokument nebyl uložen. Možné příčiny: Dokument je otevřen nebo došlo při ukládání k chybě.

A zažlutí mi:
WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & WS.Name & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

sešit jsem samozřejmě uložil po úpravě makra.

Dodatečně přidáno po 16 minutách 46 vteřinách:
Omlouvám se už funguje.
Na D:\ nebyl vytvořen adresář. Po vytvoření krásně publikuje každý list zvlášť do pdf.
Děkuji moc.

Jen mě ještě napadlo byl by problém kdyby každý list zapisoval do svoji složky ? se stejným názvem dle listu ?
Př.

D:\Action corner_makro\List1\list1.pdf
D:\Action corner_makro\List2\list2.pdf

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Excel - makro na uložení sešitu

Příspěvekod elninoslov » 05 čer 2020 11:17

Tak použite takéto niečo:

Kód: Vybrat vše

Sub ExportListsToSeparatedPDFs()
Dim WS As Worksheet, Path As String, wsPath As String, ErrCount As Integer

    Path = "D:\Users\uid40697\Desktop\Action corner_makro\test\"
    For Each WS In ThisWorkbook.Worksheets
        wsPath = Path & WS.Name & "\"
            If Create_Dir_Structure(wsPath) Then
            WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=wsPath & WS.Name & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Else
            ErrCount = ErrCount + 1
        End If
    Next WS
   
    If ErrCount > 0 Then MsgBox "Některé adresáře (" & ErrCount & ") nebyli vytvořené !", vbCritical, "ERROR !"
    Set WS = Nothing
End Sub


Kód: Vybrat vše

Function Create_Dir_Structure(D As String) As Boolean
Dim S() As String, i As Byte, Path As String

    If Len(D) < 3 Then Exit Function
    S = Split(D, "\")
    If UBound(S) = 0 Then Exit Function
    Path = S(0)

    On Error GoTo KONIEC
    For i = 1 To UBound(S)
        Path = Path & "\" & S(i)
        If Len(Dir(Path, vbDirectory)) = 0 Then MkDir Path
    Next i

KONIEC:
    Create_Dir_Structure = Err.Number = 0
End Function


EDIT 6.6.2020 8:28 : Pridal som 1 riadok kódu aby vypísalo správu ak niektorý adresár nebolo možné vytvoriť.
Přílohy
Export listov do samostatných PDF.xlsm
(22.23 KiB) Staženo 46 x


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Makro pro myš Rapture Python
    od mmmartin » 27 srp 2023 15:18 » v Problémy s hardwarem
    9
    1111
    od mmmartin Zobrazit poslední příspěvek
    29 srp 2023 16:47
  • Excel a OneDrive
    od sginfo » 11 zář 2023 15:28 » v Kancelářské balíky
    16
    5993
    od mirekol Zobrazit poslední příspěvek
    20 říj 2023 08:31
  • excel-posun makra
    od actionboy » 12 bře 2024 18:59 » v Kancelářské balíky
    1
    266
    od Grimm Zobrazit poslední příspěvek
    12 bře 2024 21:43
  • Excel - vlastní formát Příloha(y)
    od Story-Long » 11 srp 2023 14:50 » v Kancelářské balíky
    3
    1841
    od Story-Long Zobrazit poslední příspěvek
    14 srp 2023 10:11
  • Excel - problém se vzorci
    od honzzicek » 28 čer 2023 21:45 » v Kancelářské balíky
    2
    1641
    od honzzicek Zobrazit poslední příspěvek
    01 črc 2023 08:57

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 7 hostů