< návrat zpět

MS Excel


Téma: Makro kopie listu + hypertext rss

Zaslal/a 25.2.2021 8:44

Dobrý den, v makrech a vba se vůbec nevyznám, tak Vás zkušené poprosím o radu s vytvořením tohoto makra.

Potřeboval bych aby makro, které spustím na aktivní buňce ve sloupci A na listu Seznam udělalo kopii listu VZOR s umístěním na konec sešitu, pojmenovalo ho shodně s obsahem aktivní buňky ve sloupci A + vytvořilo hypertextový odkaz na tento nový list.

Vzor přikládám a bylo by to takto možné?

Děkuji

Příloha: rar49944_sesit1.rar (21kB, staženo 2x)
Zaslat odpověď >

Strana:  1 2   další »
#049946
elninoslov
To nebude problém. Len ak vkladáte prílohu XLSM musíte ju zabaliť do ZIP/RAR.citovat
#049947
avatar

elninoslov napsal/a:

To nebude problém. Len ak vkladáte prílohu XLSM musíte ju zabaliť do ZIP/RAR.


Ok, děkuji a mohl bych poprosit o kód. Přílohu jsem opravil.citovat
#049948
elninoslov
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.citovat
#049949
avatar

elninoslov napsal/a:

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.Příloha: 49948_vytvareni-listu-ze-vzoru-s-hyperlinkem.zip (21kB, staženo 2x)


Děkuji, je to super. Ta změna názvu podle listu byla první varianta, kterou jsem to chtěl řešit, ale nakonec to zvládne vaše makro. Do bunky A3 mně to ale vkládá název to bych chtěl z makra zrusit. Co bych ale potřeboval a bylo by to dokonale, kdyby to umelo vlozit na nově vytvořený list do bunky B10 číslo, které je uvedené na stejném řádku ve skoupci A v seznamu. Příklad: na listu "seznam" pustím makro na bunce C4 a makro probehne jako nyní jen jeste vlozi na nový list do bunky B10 obsah bunky A4 z listu "seznam". Tak to by to bylo automatizovane uplne TOP dle mých předtav. Upraveny soubor přikládám a jeste moc prosím o úpravu.citovat
#049950
elninoslov
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 7

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.citovat
#049951
avatar
Omlouvám se za komplikace, ale netušil jsem ze mně toto vyřeší jedno makro.

Ad 1) nee nebude, už není potřeba, vyřešil jste to makrem kde se list pojmenuje podle toho z jaké buňky je makro spuštěno.

Ad 2) V seznamu je to co půjde jako název listu z buňek ve sloupci C (např: abcde) a do buňky B10 v novém makrem vytvořeném listu se dotáhne buňka ze sloupce A stejného řádku (dle příkladu abcde = 12345).

Děkuji za čas a úpravucitovat
#049953
elninoslov
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 ...citovat
#049954
avatar
Přehodil jsem makro do svého souboru, ale nefunguje, seklo se to bohužel hned na začátku. Bude asi nejlepší když pošlu svůj soubor na kterém to budete moct odladit a budete moct potom i s makrem poslat zpět.

Děkuji a soubor je v příloze
Příloha: rar49954_reporting-nakup-2.rar (81kB, staženo 1x)
citovat
#049958
elninoslov
Skúste. Je to aj s popisom (ignorujte pls gramatické chybky).
Příloha: zip49958_reporting-nakup-2.zip (90kB, staženo 3x)
citovat
#049960
avatar

elninoslov napsal/a:

Skúste. Je to aj s popisom (ignorujte pls gramatické chybky).Příloha: 49958_reporting-nakup-2.zip (90kB, staženo 2x)


Otestoval jsem a funguje perfektně. Koukal jsem, že jste upravil i kódy u navigace. Snad jste z Brna můžu se revanšovat třeba u pivka. :-) Ještě jednou děkuju moc a jste fakt king.citovat

Strana:  1 2   další »

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

Makro - roztřídit

elninoslov • 15.4. 0:34

Makro - roztřídit

Denisa96 • 14.4. 21:57

sčítání podle kritérií

lubo • 14.4. 19:26

Vyhledat příjmení a jméno v buňce

czhoumer • 14.4. 18:35

Seskupení dat do grafu

bobika99 • 14.4. 16:23

sčítání podle kritérií

elninoslov • 14.4. 15:49

Vyhledat příjmení a jméno v buňce

kabaka • 14.4. 15:21