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

Příspěvky uživatele

Tyto dva vzorce nefungují:
=IFERROR(INDEX(DataDopln[text];MATCH("*";IFERROR(""&MATCH(DataDopln[cislo];[@[Číslo účtu ]];0);FALSE);0));"")

=IFERROR(INDEX(DataDopln[text];MATCH(1;COUNTIF([@[Číslo účtu ]];DataDopln[cislo]);0));"")

Každopádně děkuji.
Radek

@Jiří497
Jj, to funguje, ale není to úplně "universální", protože, kdybych potřeboval například hledat navíc například "08????", musel bych editovat vzorec.
U některých syntetických účtů dosazuji podle prvních 2 znaků, někdy podle prvních 3 a někdy mohu dosazovat i jen podle 1 znaku.

@lubo
můj excel tu fci FILTER nezná, nebo já jsem úplná lama

@elninoslov
ani jedna ta funkce mi neukáže výsledek. všude mám prázdné buňky.
S tím počtem znaků jsem se ukliknul

Převedl jsem nyní zdrojová data a data na listu na doplnění na formát Tabulka, ten používám většinou s ohledem na měnící se rozsahy dat.
Můžete se na to prosím podívat?
Děkuji všem.
Radek

Dobrý den, mohl byste mi někdo poradit se zástupnými znaky při využití u fce SVYHLEDAT?
Jakým způsobem bych mohl použít zástupný znak "*" nebo "?" nebo nějaký jiný tak, abych:
Na listu "list2" doplnil do sloupce "dopln" hodnotu z tabulky na listu "dopln" z druhého sloupce.
Vím, že data na listu "list2" je ve sloupci "A" počet znaků 6.
Je to nějak řešitelné pouze přes funkci?
Děkuji.
Radek

EDIT
Tak když se soubor vyexportuje z Informačního systému na počítači s win, tak vše funguje korektně.
Pokud však kolega exportuje soubor z Informačního systému na Mac tak to nefunguje.
Po exportu na Mac ten vyexportovaný soubor ani neotevře, ale jen ho zkopíruje na počítač s win a pak ho chce načíst, tak to nefunguje.
Takže to bude vše dělat na počítači s win a je to.
__________________
Díky za info.
Jenže mě to někdy nejde ani na windows a ukazuje mi to chybu na tomto řádku
If FileDateTime(sDir & sFileTemp) > dFileTime Then
a vůbec netuším, čím to je?
Musí tam tento řádek být, nedalo by se to nějak eliminovat?
Myslel jsem, že to mohlo být i nějakou diakritikou v názvech souborů nebo tak, ale fakt nevím.
Ten Mac už řešit nebudu, kolega si to může spustit na win.
Přikládám zdroje.
Děkuji.
Radek

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

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse