Přidat otázku mezi oblíbenéZasílat nové odpovědi e-mailem 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

Předmět Autor Datum
si to oddebuguj, ne? BTW, pokud je v C3 text, nedává smysl použít metodu .text, ale postačí .value
touchwood 12.04.2025 16:44
touchwood
díky Ještě dotaz tento kód nejde =KDYŽ(H1<>"";"SPD*1.0*ACC:CZ2755000000000084966004*AM:" & NAHRADI…
Mati 13.04.2025 12:30
Mati
=KDYŽ(H1<>"";"SPD*1.0*ACC:CZ2755000000000084966004*AM:"&DOSADIT(HODNOTA.NA.TEXT(I1;"0,00");",";".")&…
Siki83 13.04.2025 16:39
Siki83
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…
Mati 16.04.2025 15:33
Mati
Jak to ukládáš v PDF?
Wikan 16.04.2025 17:13
Wikan
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í…
Mati 16.04.2025 17:38
Mati
Nějak nechápu, asi to přenechám někomu chytřejšímu.
Wikan 16.04.2025 17:43
Wikan
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 X…
Mati 16.04.2025 18:02
Mati
Co mám vidět na tom obrázku?
Wikan 16.04.2025 18:06
Wikan
Posílám vzor v Excelu
Mati 16.04.2025 18:52
Mati
A keď Ti niekto poradí, ani si nedáš námahu sa k tomu vyjadriť alebo poďakovať...
Janko Hrasko 17.04.2025 07:10
Janko Hrasko
Nefunguje. Používat diakritiku není zrovna dobrý nápad. [99862-macros-png]
Wikan 17.04.2025 11:19
Wikan
V tom to není. Odstranil sem i všechny ostatní moduly (kdyby byl problém tam) a chyba se stále opaku…
Siki83 18.04.2025 15:01
Siki83
Však já netvrdil, že mu to nefunguje kvůli diakritice. Ale na mém stroji ta diakritika vadí. Možná k…
Wikan 18.04.2025 15:05
Wikan
Tak to vypadá, že chyba je v nastavení Excelu viz: why-do-my-hyperlinks-in-excel-change-to-a-roaming… poslední
Siki83 18.04.2025 16:36
Siki83

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

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í'.

Zpět do poradny Odpovědět na původní otázku Nahoru