Příspěvky uživatele
< návrat zpět
Skúste. Je to aj s popisom (ignorujte pls gramatické chybky).
Otestujte. Vašu prílohu som nesťahoval. Ponechal som aj to premenovanie listu a aktualizáciu linku pri zmene A3. Dajte vedieť. Ale teraz idem na čas od PC ...
Sakra, akurát som to všetko upravil, aj sprevádzkoval technicky (pamätanie si predchádzajúceho názvu a opravenie linku) aj logicky, idem to poslať, a Vy bác zmena 
1. Takže v tom liste nebude nikde bunka s názvom daného listu, pri ktorej zmene by sa premenoval list a opravil link v "Seznam"?
2. V Seznam v stĺpe A je to, čo pôjde ako názov listu, a v C je to čo pôjde do B10?
PS: Odstráňte citáciu z príspevku, je jasné na čo reagujete, citáciu netreba.
Spravil som to takto:
-overuje existenciu listu
-ak list existuje, overí či odkaz v tej bunke sedí s textom v bunke a prípadne odkaz opraví
-ignoruje prázdne bunky
-funguje na multioblasť
-spúšťa sa skratkou Ctrl+M
Sub Vytvor_list()
Dim Are As Range, Bunka As Range, H(), x As Integer, y As Long, idx As Integer
If TypeName(Selection) <> "Range" Then MsgBox "Vyberte oblast buněk.", vbExclamation: Exit Sub
idx = Worksheets.Count
Application.ScreenUpdating = False
For Each Are In Selection.Areas
If Are.Cells.Count = 1 Then ReDim H(1 To Are.Rows.Count, 1 To Are.Columns.Count): H(1, 1) = Are.Value Else H = Are.Value
For y = 1 To UBound(H, 1)
For x = 1 To UBound(H, 2)
If Not IsEmpty(H(y, x)) Then
Set Bunka = Are.Cells(y, x)
With Bunka
If Kontrola_NeExistence(CStr(H(y, x))) Then
If .Hyperlinks.Count > 0 Then
If Not Range(.Hyperlinks(1).SubAddress).Parent.Name = H(y, x) Then .Hyperlinks.Add Anchor:=Bunka, Address:="", SubAddress:="'" & H(y, x) & "'!A1", ScreenTip:=H(y, x)
End If
Else
wsVZOR.Copy After:=Worksheets(idx)
ActiveSheet.Name = H(y, x)
ActiveSheet.Range("A3") = H(y, x)
.Hyperlinks.Add Anchor:=Bunka, Address:="", SubAddress:="'" & H(y, x) & "'!A1", ScreenTip:=H(y, x)
idx = idx + 1
End If
End With
End If
Next x
Next y
Next Are
wsSeznam.Activate
Application.ScreenUpdating = True
End Sub
Function Kontrola_NeExistence(sName As String) As Boolean
On Error Resume Next
Kontrola_NeExistence = Len(Worksheets(sName).Name)
End Function
Vy tam máte ale ešte makro, ktoré Vám pri zmene bunky A3 v ktoromkoľvek liste zmení jeho názov na zmenenú hodnotu.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$3" Then Exit Sub
ActiveSheet.Name = Range("a3").Value
End Sub
Tu vidím veľký problém v tých odkazoch. Vy keď zmeníte názov listu zmenením tej bunky A3, tak Vám prestane správne odkazovať link v liste Seznam.
To nebude problém. Len ak vkladáte prílohu XLSM musíte ju zabaliť do ZIP/RAR.
???
A čo je výstupom toho odkazu na iný zošit, ak ten iný zošit neobsahuje hodnotu? Bunka s hodnotou "" ošetrené vzorcom? Alebo bunka s hodnotou 0 (takú návratovú hodnotu dostanete štandardne) ošetrená formátom? To je predsa zásadná informácia.
V tom mojom vzorci som počítal s tým "".
...(A1:A50<>"")...
Sub TlacPDF()
Dim Adresar As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
Adresar = .SelectedItems(1)
Adresar = Adresar & IIf(Right(Adresar, 1) = "\", "", "\")
ActiveSheet.Range("C2").Value = Adresar
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Adresar & "TlacPDF.pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End With
End Sub
Myslíte tlač z makra?
Sub TlacPDF()
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1) & "\TlacPDF.pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End With
End Sub
Tak som si prešiel jedno MS fórum, a vyzerá to žiaľ zatiaľ tak, že bezradný nie sme len my, ale i samotný M$. Problém je častý, a s typickými radami od M$ (rozumejte na prd).
Iba maličká technická: Priradenie do premennej "i" je v prípade ďalšieho nespracovania zbytočné. Dajte rovno
Select Case MsgBox("testovat", vbYesNoCancel + vbQuestion, "test")
Tieto 3 súbory sú kombináciou čísel a písmen, a normálne mi fungujú.
(122)Mobis Labak ECU SW.docx
456 juhfsdf.docx
jaidf56.docx
Keď si nejaký iný premenujem na napr. 7A.docx, tiež normálne funguje.
Skúste dať v kóde BreakPoint-y (klik sivý pásik vľavo od kódu) na riadky
Bunka.Hyperlinks.Delete
a
Bunka.Value = Subor
Zadajte číslopísmenný názov (existujúci) a písnite na ktorom riadku to zastaví. Následne nechajte kód dobehnúť (hore zelené tlačítko Play), lebo by ostali vypnuté udalosti.
A písnite tú verziu Office.
Lucia16116 napsal/a:
nerobí čo by mal...
A to je čo? Mne to funguje. Jediným rozdielom u mňa je, že nemám OneDrive, a posielam linky do klasického adresára. V tom by teoreticky mohol byť problém, lebo OneDrive adresár je špeciálny typ adresára, kde sú často len odkazy na súbory, tie sa reálne stiahnu až keď sa súbor použije. Skúste presmerovať makro na iný adresár (nie OneDrive). Potom ešte pripíšte verziu Office. Ja mám O2019.
Je to Worksheet_Change, teda udalosť listu. Takže to musí ísť do modulu daného listu (u Vás je to "List1 (Hárok1)"), nie do normálneho modulu.
EDIT:
A ešte, ak máte pevnú zložku, tak nemôžete použiť to, čo tam máte
Zlozka = ThisWorkbook.Path & "C:\Users\Lucka\OneDrive\Počítač\MO\Excel revizie upozornovanie\Revizie dokumenty\"
ale musí to byť bez toho "ThisWorkbook.Path"
Zlozka = "C:\Users\Lucka\OneDrive\Počítač\MO\Excel revizie upozornovanie\Revizie dokumenty\"
Lebo s tým, vlastne zreťazíte 2 cesty. Cestu k aktuálnemu súboru a cestu manuálne zadanú v reťazci. A vtedy Vám to nebude fachať, čo je jasné.
Prípadne prvý riadok kódu upravte na
Set Zmena = Intersect(ListObjects("Tabuľka1").DataBodyRange.Columns(3), Target)
a bude to kontrolovať iba 3 stĺpec objektu Tabuľka1, a nie celý stĺpec C.
Formátovanie, zlúčené bunky a pod, to jedine makrom, a to tak, že pri aktivácii daného súhrnného listu by prebehla aktualizácia. Inak to možné nie je. Vložte prílohu s pár listami, pár riadkami dát, a manuálne vytvorený požadovaný výsledok. Nech je jasné, či sú listy rovnakej šírky, či sa ku každému listu kopíruje aj jeho hlavičkový riadok alebo sú rovnaké, a množstvo iných vecí. Proste manuálne vyrobte požadovaný vzor a makro prispôsobíme...
Function EVAL_WORKDAY(Datum As Date, Dni As Long) As Date
Dim Rok As Long
Rok = Year(Datum)
EVAL_WORKDAY = Evaluate("=WORKDAY(" & CDbl(Datum) & "," & Dni & ",DATEVALUE(MID(SUBSTITUTE(""01/01*""&TEXT(DOLLAR((""4/""&" & Rok & ")/7+MOD(19*MOD(" & Rok & ",19)-7,30)*14%,)*7-5,""mm/dd"")&""*05/01*05/08*07/05*07/06*09/28*10/28*11/17*12/24*12/25*12/26*"",""*"",""/""&" & Rok & "),(ROW(1:12)-1)*10+1,10)))")
End Function
Uživatelské menu
\nFormulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články