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

Příspěvky uživatele

Dobrý den,
prosím, můžete mi někdo poradit (zeditovat), proč se nenajde na MacBook ten soubor uložený v adresáři "data-platby"?
Adresář je uložen ve stejném adresáři, jakou sešit, ve kterém spouštím to makro.
Na WIN to funguje velmi dobře od doby, kdy mi to pomohl @elninoslov napsat.
Děkuji.
Radek
Sub doPDF_bezCOPY_proHS_adresář()

Dim sDir As String, sSoubor As String, sDate As String, sKod As String, MAIL_ADRESAT As String
Dim bTypSpravy As Byte, bOteviranyOutlook As Boolean, MyDate As Date
Dim OutApp As Object, OutMail As Object ', oUcet As Object

'Const ODESILATEL_MAIL = "elninoslov@gmail.com" 'v případě vícero účtů v Outlooku se bude odesílat z tohoto
Const ZAVRIT_OUTLOOK = True 'v případě, že Outlook otevře makro, má ho pak zavřít (True) nebo nechat otevřen (False)
Const ODESLAT_MAIL = False 'True - mail odešle, False - mail pouze vytvoří


'příprava adresáře

With ThisWorkbook.ActiveSheet 'toto pracuje s aktuálním Listem

sKod = .Range("B2").Value2 'kód hospodářského střediska
sDir = ThisWorkbook.Path & "\Export\" & sKod & "\" 'nastavení adresáře referenta do složky Export

'sDir = ThisWorkbook.Path & "\__pdfhs - " & sKod & "\" 'nastavení adresáře hospodářského střediska

'sDir = ThisWorkbook.Path & "\__pdfhs\" 'původní nastavení do přímo zvoleného adresáře

If Len(Dir(sDir, vbDirectory)) = 0 Then 'kontrola existence adresáře hospodářského střediska
If MsgBox("Adresář neexistuje." & vbNewLine & vbNewLine & "Přejete si ho vytvořit?" & vbNewLine & vbNewLine & sDir, vbYesNo + vbQuestion) = vbNo Then Exit Sub
If Not Vytvor_Adresarovou_Strukturu(sDir) Then bTypSpravy = 1: GoTo KONEC 'chybová správa o vytváření adresáře
End If

sDate = Format(Date, "yyyy-mm-dd") 'Rozhoduje pořadí, bere se ta poslední varianta, řádek

'příprava souboru

On Error Resume Next

'MAIL_ADRESAT = "niekto@odniekial.com" 'konkrétní adresát
MAIL_ADRESAT = "" 'adresát je prázdný

'MAIL_ADRESAT = .Range("B5").Value2 'adresát z konkrétní buňky, nebo adresáti v buňce oddělení středníkem

sSoubor = sDir & .Range("B1").Value2 & "-" & .Range("A1").Value2 & " _ " & sKod & ".pdf" 'složí název souboru
'sSoubor = sDir & sDate & " - " & sKod & " - " & .Name & ".pdf" 'složí název souboru
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sSoubor, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'export do PDF
End With

If Err.Number <> 0 Then bTypSpravy = 2: GoTo KONEC 'chybová správa o vytváření souboru

'příprava Outlooku

'Set OutApp = GetObject(, "Outlook.application") 'ověření, zda není Outlook otevřený

'If OutApp Is Nothing Then
'Set OutApp = CreateObject("Outlook.Application") 'otevření Outlooku, pokud není otevřen
'If Not OutApp Is Nothing Then bOteviranyOutlook = True Else bTypSpravy = 3: GoTo KONEC 'chybová správa o otvírání Outlooku
'End If
'On Error GoTo 0

'For Each oUcet In OutApp.Session.Accounts 'v případě vícero účtů v Outlooku, nalezení toho, z kterého se má odesílat
' If oUcet.CurrentUser.Address = ODESILATEL_MAIL Then Exit For
'Next oUcet

'If oUcet Is Nothing Then bTypSpravy = 4: GoTo KONEC 'chybová správa - požadovaný účet není v Outlooku nalezen


'příprava mailu

'On Error Resume Next
'Set OutMail = OutApp.CreateItem(0) 'vytvoření emailu
'With OutMail
' .To = MAIL_ADRESAT 'adresát
' .CC = ""
' .BCC = ""
' .Subject = "Pohledávky po splatnosti HS " & sKod
' .Body = "Posíláme pohledávky po splatnosti pro HS " & sKod
'.Attachments.Add sSoubor
'Set .SendUsingAccount = oUcet 'Odesílá pomocí zvoleného účtu

'If ODESLAT_MAIL Then .Send 'Else .Display 'podle volby se mail odešle (True), nebo pouze vytvoří (False)
'End With
'If Err.Number <> 0 Then bTypSpravy = 5
'On Error GoTo 0

'vyhodnocení

KONEC:
'AppActivate ThisWorkbook.Windows(1).Caption

Select Case bTypSpravy 'vyhodnocení - správa o chybách
'Case 0: MsgBox "Vytvoření PDF - OK" & vbNewLine & IIf(ODESLAT_MAIL, "Odeslání", "Vytvoření") & " mailu - OK", vbInformation
Case 0: MsgBox "Vytvoření PDF - OK", vbInformation
If Not ODESLAT_MAIL And Not OutMail Is Nothing Then OutMail.Display 'zobrazení vytvořeného emailu
Case 1: MsgBox "Tento adresář nebylo možné vytvořit !" & vbNewLine & vbNewLine & sDir, vbCritical
Case 2: MsgBox "Nastala chyba při vytváření souboru !" & vbNewLine & vbNewLine & sSoubor, vbCritical
Case 3: MsgBox "Není možné otevřít Outlook !" & vbNewLine & vbNewLine & sSoubor, vbCritical
'Case 4: MsgBox "Vytvoření PDF - OK" & vbNewLine & "Odeslání mailu - účet neexistuje ( " & ODESILATEL_MAIL & " )", vbExclamation
Case 5: MsgBox "Vytvoření PDF - OK" & vbNewLine & "Odeslání mailu - chyba !", vbExclamation
If Not ODESLAT_MAIL And Not OutMail Is Nothing Then OutMail.Display 'zobrazení vytvořeného emailu
End Select

'v případě, že Outlook byl otvíraný makrem, mail hned odesílaný (ODESLAT_MAIL=True), a je třeba ho zavřít (ZAVRIT_OUTLOOK=True) - tak se zavře
'If bOteviranyOutlook And ZAVRIT_OUTLOOK And ODESLAT_MAIL Then OutApp.Quit

'zrušení objektů
Set OutApp = Nothing: Set OutMail = Nothing ': Set oUcet = Nothing
End Sub

Function Vytvor_Adresarovou_Strukturu(ByVal sDir As String) As Boolean 'Vytvoření adresářové struktury, včetně podadresářů
Dim F() As String, i As Integer

F = Split(sDir, "\") 'rozdělí cestu na podadresáře
sDir = ""

With CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For i = 0 To UBound(F) - 1 'postupně kontroluje a vytváří podadresáře (poslední lomítko vynechá - ošetřeno na začátku)
sDir = sDir & IIf(Len(sDir) = 0, "", "\") & F(i)
If Not .FolderExists(sDir) Then .CreateFolder sDir
Next i
End With

Vytvor_Adresarovou_Strukturu = Err.Number = 0 'False - když nastala chyba
End Function

'Sub Vypis_Uctov_Outlooku() 'pouze kontrolní makro pro výpis seznamu účtů v Outlooku a jejich adres
'Dim OutApp As Object, oUcet As Object
'
' On Error Resume Next
' Set OutApp = GetObject(, "Outlook.application") 'ověření, zda není Outlook otevřený
'
' If OutApp Is Nothing Then
' Set OutApp = CreateObject("Outlook.Application") 'otevření Outlooku, pokud není otevřen
' If OutApp Is Nothing Then Debug.Print "CHYBA" 'chybová správa o otvírání Outlooku
' End If
' On Error GoTo 0
'
' For Each oUcet In OutApp.Session.Accounts 'výpis účtů
' Debug.Print oUcet & "......." & oUcet.CurrentUser.Address
' Next oUcet
'
' Set OutApp = Nothing: Set oUcet = Nothing
'End Sub

posláno

Super, děkuji.
Radek
a kam mám poslat příspěvek?

Jj, jsou tam i kratší, já tam dal vše, pak to budu mít vyčištěné před prvním nasazením.
Ale stále, když zadám například 7 pouze písmen, tak se to uloží.
Já to nenapsal původně. Mělo by tam být číslo, někde, u ele aut bude třeba až od třetí pozice, ale bude tam vždy alespoň jedno číslo.. A písmeno musí být na druhé pozici.
Díky.
Radek
kam vám mohu přispět?

Jj, už jsem použil váš soubor s tím přejmenováním.
Když zadám například 1234567, tak se RZ uloží.
Ale v RZ musí být minimálně jedno písmeno a to na druhé pozici.
U elektroauta jsou první dva znaky "EL".
Celkový počet znaků RZ je 7, ty na přání mají 8.
Šlo by to nějak zakomponovat do těch podmínek?
Děkuji.
Radek

@elninoslov
Zkusil jsem váš kod, ale vyskakuje mi tam tato chyba:
Set LO = wsKJ.ListObjects("DataKj") 'název Tabulky na listě kj

List má název "kj" a je na něm tabulka s názvem "DataKj"

Ostatním samozřejmě také děkuji.
Radek

Dobrý den,
mohli byste mi někdo , prosím, zeditovat níže uvedené makro?
V Dimenzi "kj" může být číslo nebo velké písmeno.
Měl jsem makro o vás tady z fóra na jméno a příjmení, ale tam jsem kontroloval jen to, že tam jsou jen písmena a první písmeno je velké.
Tady potřebuji:
buď číslo nebo velké písmeno a zároveň délka 7 znaků (alfanumerických).
Zkusil jsem to sám, ale zkolaboval jsem na číslech.
Přkládám i soubor.
Děkuji.
Radek

Sub Nova_KJ()

Dim kj As String
Dim jmeno As String
Dim radek As Long

On Error Resume Next 'pokud uživatel stiskne klávesu ESC, kód skočí do řádku s "Exit Sub"

Do
kj = InputBox("Zadejte novou RZ: (bez mezer, a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel")

If Err.Number <> 0 Then 'pokud uživatel stiskne klávesu ESC, ukončí se makro
Exit Sub
End If

'jmeno = InputBox("Zadejte jméno: (bez mezer, čísel a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel")

If Err.Number <> 0 Then 'pokud uživatel stiskne klávesu ESC, ukončí se makro
Exit Sub
End If

On Error GoTo 0 'vynulování chybového čísla

If kj = "" Then
Exit Sub
End If

If Not (IsUpper(kj) And _
IsNumeric(kj) And _
Len(kj) = 7 Or Len(kj) = 0 Or Len(kj) < 7) Then


'If Not (IsUpper(Left(prijmeni, 1)) And IsUpper(Left(jmeno, 1)) And _
' IsOnlyLowerCase(Right(prijmeni, Len(prijmeni) - 1)) And _
'IsOnlyLowerCase(Right(jmeno, Len(jmeno) - 1)) And _
'IsOnlyLetters(prijmeni) And IsOnlyLetters(jmeno) And _
'Len(prijmeni) > 1 And Len(jmeno) > 1) Then

MsgBox "Opravte RZ - (bez mezer, a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel"
Else
If Sheets("kj").Range("A2") = "" Then
radek = 2
Else
radek = Sheets("kj").Range("A" & Rows.Count).End(xlUp).Row + 1
End If

Sheets("kj").Range("A" & radek).Value = kj
Exit Do
End If
Loop

With ThisWorkbook.Sheets("kj")
.Range("A2").Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlYes
End With

Dim ws As Worksheet
Dim lastRow As Long, i As Long, j As Long
Set ws = ThisWorkbook.Sheets("kj") 'název listu

lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

For i = 2 To lastRow 'prochází každý řádek od 2. řádku až po poslední
For j = i + 1 To lastRow 'prochází každý řádek nad aktuálním řádkem
If ws.Cells(i, "A").Value = ws.Cells(j, "A").Value Then 'pokud jsou hodnoty v sloupci A stejné, vymaže řádek
ws.Rows(j).EntireRow.Delete
lastRow = lastRow - 1 'aktualizuje poslední řádek, protože byl odebrán řádek
j = j - 1 'decrementuje j, aby se při dalším průchodu prozkoumal nový řádek, na který se posunul
End If
Next j
Next i

MsgBox ("HOTOVO- nová RZ uložena")

End Sub

Function IsUpper(text As String) As Boolean
IsUpper = (text = UCase(text))
End Function

Function IsOnlyLowerCase(text As String) As Boolean
IsOnlyLowerCase = (text = LCase(text))
End Function

Function IsOnlyLetters(text As String) As Boolean
Dim i As Integer
For i = 1 To Len(text)
If Not (Asc(Mid(text, i, 1)) >= 65 And Asc(Mid(text, i, 1)) <= 90) And _
Not (Asc(Mid(text, i, 1)) >= 97 And Asc(Mid(text, i, 1)) <= 122) And _
Not (Asc(Mid(text, i, 1)) >= 138 And Asc(Mid(text, i, 1)) <= 254) Then
IsOnlyLetters = False
Exit Function
End If
Next i
IsOnlyLetters = True
End Function

Super díky za odpověď.
Já to předělávat nebudu, ať si to pustí na windows.
Každopádně děkuji.
Radek

Dobrý den,
s souboru, viz příloha, mám makro přes tlačítko na uložení do *.pdf.
Mám to tady od někoho od vás a funguje mi to super.
Nicméně, když to pošlu kolegovi, které má MacBook Pro tak po spuštění makra pro uložení do *.pdf mu hlásí tuto chybu:
„Run-time Error 429 ActiveX component cant create object"

Dá se to makro nějaku pravit, aby fungovalo i na MacOS nebo to nelze?
Děkuji.
Radek

Jj, v tomto konkrétním případě, tabulka "kj" nejsou.
Ale chtěl jsem řešit jiné tabulky, kde duplicity byly přes relace v Power Pivot a nevěděl jsem si rady.

Děkuji, jsem lama.
Já si totiž myslel, že když v tabulce "data" přidám ten sloupec "Vuz", nebudu muset používat relace v Power Pivot.
Já mám totiž relaci mezi tabulkou "kj" a tabulkou "data".
Akorát se budu muset ještě naučit v Power Pivot relace N:N, tedy ne jen 1:N.
Ještě jednou děkuji.
Radek

Dobrý den, chci se zeptat, zda tento může výrazně zpomalit načítání respektive aktualizaci Dat z Power Query?

let
currentKJ = [Kalkulační jednice],
matchingRow = Table.SelectRows(kj, each [Kalkulační jednice] = currentKJ),
matchingTypVozu = if Table.RowCount(matchingRow) = 1 then matchingRow{0}[Název kalkulační jednice] else ""
in
matchingTypVozu

Když jsem kod doplnil vložením do vytvořeného sloupce "Vuz" v tabulce "data" tak to bylo rychlé a viděl jsem výsledek.
Ale když jsem pak dal Zavřít a načíst, tak se to stále načítá... a trvá to stále dlouho a nemůže se to ukončit.
Soubor jsem zatím nedával, protože je veliký.
v té tabulce "data" jsou načteny roky z účetního deníku 2021, 2022 a 2023, takže jsou to desítky tisíc řádků.
Nicméně do doby vložení toho kodu mi vše běželo hladce :-)
Ten kod kontroluje sloupec "Kalkulační jednice" v tabulce "data" se sloupcem "Kalkulační jednice" v tabulce "kj". Pokud najde shodu, doplní do sloupce "Vuz" v tabulce "data" hodnotu ze sloupce "Název kalkulační jednice" z tabulky "KJ".
V tabulce "kj" nejsou ve sloupci "Kalkulační jednice" duplicity.
Děkuji.

Super, děkuji, takto stačí.
Radek

Jj, funguje je to.
Akorát, když zadávám data a chci přejít "šipkou" ze sloupce "D" de facto přes sloupec "E" do sloupce "F" a skočím do sloupce "E", automaticky se mi kurzor přesune do sloupce "A" o řádek níž.
Musím jedině kliknout do "F" myší.
Nejde to nějak ošetři, aby se ten sloupec "E" přeskočil v tom samém řádku, pokud se budu pohybovat šipkami?
Jde mi jen o komfort zadávání dat.
Ale každopádně děkuji.
Radek

Tak asi dělám něco fakt špatně...
Já to takto udělal.
Spíš si myslím, jestli nemám špatně to VBA?

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse