
Vzorec VBA
DOBRÝ DEN MÁM FUNKCI NAPŘÍKLAD
Sub TestPrevod()
Dim vstup As String
Dim vysledek As String
' Načti text z C3 (např. "S T V R Z E N K A")
vstup = Sheets("Stvrzenka").Range("C3").Text
' Odstraň mezery a převed na správný tvar (např. "Stvrzenka")
vysledek = StrConv(Replace(vstup, " ", ""), vbProperCase)
' Zapiš výsledek do O9
Sheets("Stvrzenka").Range("O9").Value = vysledek
MsgBox "Výsledek: " & vysledek
End Sub
Do buňky O9 by to mělo napsat Stvrzenka ale nezapíše mi to můžete mi prosím poradit?
Moc děkuji
si to oddebuguj, ne?
BTW, pokud je v C3 text, nedává smysl použít metodu .text, ale postačí .value
díky
Ještě dotaz tento kód nejde
=KDYŽ(H1<>"";"SPD*1.0*ACC:CZ2755000000000084966004*AM:" & NAHRADIT(TEXT(I1;"0,00");",";"." ) & "*CC:CZK*X-VS:" & H1 & "*MSG:" & H6;"")
Můžete mi prosím poradit kde je chyba?
Děkuji
Dobrý den,
mám kód:
ale když ho uložím v PDF vše je v pořádku pak to chci uložit v XLSM a odkaz také funguje ale pokud chci otevřít odkaz na tím tak to nejde otevřít.
Můžete mi prosím kód opravit?
Moc děkuji
' ===== FUNKCE: Úprava textu v C3 na čitelnou formu =====
Function UpravitNadpis(textRaw As String) As String
Dim i As Long, slozeno As String
textRaw = Trim(textRaw)
For i = 1 To Len(textRaw)
If Mid(textRaw, i, 1) <> " " Then
slozeno = slozeno & Mid(textRaw, i, 1)
End If
Next i
If Len(textRaw) > 0 And UBound(Split(textRaw, " ")) >= 4 Then
UpravitNadpis = UCase(Left(slozeno, 1)) & LCase(Mid(slozeno, 2))
Else
textRaw = LCase(textRaw)
UpravitNadpis = UCase(Left(textRaw, 1)) & Mid(textRaw, 2)
End If
End Function
' ===== TLAČÍTKO - hlavní spuštění =====
Sub Tlačítko9_Kliknutí()
Dim cestaKPDF As String
Dim fakturaCislo, jmeno, prijemce, datum, castka, popis
With Sheets("Stvrzenka")
fakturaCislo = .Range("G5").Value
jmeno = .Range("C26").Value
prijemce = .Range("K26").Value
datum = .Range("AM5").Value
castka = .Range("AG19").Value
popis = .Range("J28").Value
End With
cestaKPDF = UlozitSoubor()
If cestaKPDF = "Zruseno" Then Exit Sub
' Volání zápisu do seznamu faktur
Call ZapsatDoSeznamuFakturManual(fakturaCislo, jmeno, prijemce, datum, castka, popis, cestaKPDF)
' Volání funkce pro vymazání s dotazem
Call MazuSVolbou
End Sub
' ===== MAZÁNÍ S DOTAZEM =====
Sub MazuSVolbou()
If MsgBox("Chceš vymazat data a zvýšit číslo faktury?", vbYesNo + vbQuestion) = vbYes Then
With Sheets("Stvrzenka")
.Range("AW17").Value = 0
.Range("G5").Value = .Range("G5").Value + 1
End With
End If
End Sub
' ===== ULOŽENÍ PDF / XLSM / OBOJÍ + náhled tisku =====
Function UlozitSoubor() As String
Dim volba As String, Cas As String
Dim cestaPDF As String, cestaXLSM As String
Dim FinalName As String
Dim CestaS As String: CestaS = "E:\" ' Nastavte výchozí cestu
Dim ws As Worksheet: Set ws = Sheets("Stvrzenka")
FinalName = Trim(ws.Range("O9").text) & " - " & Trim(ws.Range("G5").text)
' Zobrazení formuláře pro volbu formátu
On Error Resume Next
UserForm1.Tag = ""
UserForm1.Show
volba = UserForm1.Tag
On Error GoTo 0
If volba = "Zrusit" Or volba = "" Then
UlozitSoubor = "Zruseno"
Exit Function
End If
' Uložení do PDF
If volba = "PDF" Or volba = "Obe" Then
cestaPDF = CestaS & FinalName & ".pdf"
If Dir(cestaPDF) <> "" Then
Cas = Format(Now, "dd.mm.yyyy - HH.MM.SS")
cestaPDF = CestaS & FinalName & " - " & Cas & ".pdf"
End If
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=cestaPDF, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
' Uložení do XLSM
If volba = "XLSM" Or volba = "Obe" Then
cestaXLSM = CestaS & FinalName & ".xlsm"
If Dir(cestaXLSM) <> "" Then
Cas = Format(Now, "dd.mm.yyyy - HH.MM.SS")
cestaXLSM = CestaS & FinalName & " - " & Cas & ".xlsm"
End If
ThisWorkbook.SaveCopyAs Filename:=cestaXLSM
End If
' Tiskový náhled (pokud je požadováno)
If MsgBox("Chceš zobrazit náhled před tiskem?", vbYesNo + vbQuestion, "Náhled tisku") = vbYes Then
ws.PrintPreview
End If
' Výběr cesty k souboru
If cestaPDF <> "" And Dir(cestaPDF) <> "" Then
UlozitSoubor = cestaPDF
ElseIf cestaXLSM <> "" And Dir(cestaXLSM) <> "" Then
UlozitSoubor = cestaXLSM
Else
UlozitSoubor = ""
End If
End Function
' ===== ZÁPIS DO SEZNAMU FAKTUR S FUNKČNÍM ODKAZEM =====
Sub ZapsatDoSeznamuFakturManual(fakturaCislo, jmeno, prijemce, datum, castka, popis, cestaPDF As String)
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Seznam faktur")
Dim r As Long, radek As Long, nalezeno As Boolean
Dim cistyText As String, zobrazenyText As String, vzorec As String
Dim existujiciOdkaz As String
For r = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If ws.Cells(r, 1).Value = fakturaCislo Then
radek = r: nalezeno = True: Exit For
End If
Next r
If Not nalezeno Then radek = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
cistyText = UpravitNadpis(Sheets("Stvrzenka").Range("C3").text)
zobrazenyText = cistyText & " " & Sheets("Stvrzenka").Range("G5").text
If ws.Cells(radek, 8).Hyperlinks.Count > 0 Then
existujiciOdkaz = ws.Cells(radek, 8).Hyperlinks(1).Address
End If
With ws
.Cells(radek, 1).Value = fakturaCislo
.Cells(radek, 2).Value = jmeno
.Cells(radek, 3).Value = prijemce
.Cells(radek, 4).Value = datum
.Cells(radek, 5).Value = castka
.Cells(radek, 6).Value = popis
' Opravený vzorec pro "Zaplaceno" při platbě "Hotově"
vzorec = "=KDYŽ(NEBO(A" & r & "<>"""";F" & r & "=""Hotově"");""Zaplaceno: "" &HODNOTA.NA.TEXT(D" & r & ";""dd.mm.rrrr"");"""")"
.Cells(r, 7).FormulaLocal = vzorec
' ===== Hyperlink zápis – vždy správně =====
.Cells(radek, 8).Value = ""
If cestaPDF <> "" And Dir(cestaPDF) <> "" Then
.Hyperlinks.Add Anchor:=.Cells(radek, 8), Address:=cestaPDF, TextToDisplay:=zobrazenyText
ElseIf existujiciOdkaz <> "" Then
.Hyperlinks.Add Anchor:=.Cells(radek, 8), Address:=existujiciOdkaz, TextToDisplay:=zobrazenyText
Else
.Cells(radek, 8).Value = zobrazenyText
End If
With .Cells(radek, 8).Font
.color = RGB(0, 0, 0)
.Underline = xlUnderlineStyleNone
End With
End With
' Jedna zpráva po úspěšném uložení souboru a zápisu do seznamu faktur
MsgBox "Soubor byl uložen a zapsán do seznamu faktur."
End Sub
Jak to ukládáš v PDF?
Dá se to uložit jak v PDF tak i XLSM ale pokud to uložím XLSM už nejde otevřít odkaz nad tím uložením XLSM.
Pokud zase uložím v PDF mohu to otevřít ale výše co již bylo uloženo nejde otevřít odkaze vše se ukládá do E:
Nějak nechápu, asi to přenechám někomu chytřejšímu.
Ukládám to do složky a to jak v PDF tak i XLSM ale když uložím PDF funguje to ale jak to uložím do XLSM tak tonahoře přepíše cestu toho odkazu.
Viz obrázek
Co mám vidět na tom obrázku?
Posílám vzor v Excelu
A keď Ti niekto poradí, ani si nedáš námahu sa k tomu vyjadriť alebo poďakovať...
Nefunguje. Používat diakritiku není zrovna dobrý nápad.
![[99862-macros-png]](https://pc.poradna.net/files/99862-macros-png)
V tom to není. Odstranil sem i všechny ostatní moduly (kdyby byl problém tam) a chyba se stále opakuje.
Však já netvrdil, že mu to nefunguje kvůli diakritice. Ale na mém stroji ta diakritika vadí. Možná kvůli anglickém systému a Excelu. Takže jsem to ani nemohl vyzkoušet.
Tak to vypadá, že chyba je v nastavení Excelu viz:
why-do-my-hyperlinks-in-excel-change-to-a-roaming-folder
U mě pomohlo změnit nastavení z odkazu
1. V Excelu otevřete nabídku Soubor a vyberte možnosti
2. V možnostech vyberte „Upřesnit“. Přejděte dolů do sekce Obecné
3. Vyberte tlačítko 'Možnosti webu'
4. V dialogovém okně Možnosti webu vyberte kartu 'Soubory'
5. Zrušte výběr možnosti 'Aktualizovat odkazy při uložení'.