makro multi hypertext excel Vyřešeno

[fmb]

Ahoj
mam vytvorene makro, ktore mi nacita obsah aktivovanej bunky otvori prislusnu kartu na nej vyhlada cislo vyrobku (toto cislo je uvedene v stlpci A, C,D,E,F (je len jedno cislo ale rozhoduje pre mna kde je napisane na zatriedenie inde su nuly tym padom sa spocitavaju a ziskam potrebne cislo produktu) a riadku tam kde je aktivovana bunka) a nakoniec vytvorim hypertext s adresou prislusnej karty a aktivovanym vyrobkom...

A otazka znie ci sa to neda nejakym sposobom prerobit na to aby to urobilo nie len pre jednu aktivovanu bunku ale pre viac buniek (tieto bunky sa nachadzaju len v 11 stlpcoch vzdy tych istych)....

makro co mam napisane:

Sub hypertext()
'premenne
Dim datatoFind
Dim currentSheet As Integer
' hypertext Makro
'
' Klávesová skratka: Ctrl+h
'
'nacitanie aktivnej bunky adresa + text

sortcell = ActiveCell.Address
adresa = ActiveCell.Address(rowabsolute:=False, columnabsolute:=False)
Range(sortcell).Select
a = Range(sortcell).Text
'nacitanie cisla tovaru podla riadku v ktorom sa nachadza aktivna bunka
b1 = Cells(ActiveCell.Row, 1)
b2 = Cells(ActiveCell.Row, 3)
b3 = Cells(ActiveCell.Row, 4)
b4 = Cells(ActiveCell.Row, 5)
b = b1 + b2 + b3 + b4


'nacitanie adresy sheet pre navrat
currentSheet = ActiveSheet.Index
' zadanie dat na vyhladanie
datatoFind = b
'vyhladanie na sheete s menom z oznacenej bunky
Sheets(a).Activate
Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate



'nacitanie do premennej c adresy najdenej bunky
c = ActiveCell.Address
'navrat po hladani na povodny zosit
Sheets(currentSheet).Activate
Range(adresa).Activate

'vytvorenie hyperlinku na subor "times" zosit "a" odkaz na bunku "c"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="times.xlsx", _
SubAddress:="'" & a & "'!" & c

End Sub

[Reklama]

[cmuch]

Ahoj,
možná takto - do řádku s bigRange si dej všechny bunky kterých se to týká.

Vyzkoušej na záloze původního souboru, kdyby se to náhodou nepovedlo.

Kód: Vybrat vše

Sub hypertext()
'premenne
Dim datatoFind
Dim currentSheet As Integer

Dim bigRange As Range
Dim RangebigRange As Range
' hypertext Makro
'
' Klávesová skratka: Ctrl+h
'
'nacitanie aktivnej bunky adresa + text
Application.ScreenUpdating = False

Set bigRange = Application.Union(Range("A5"), Range("B7:C78"), Range("j7:j78"))

For Each RangebigRange In bigRange

    RangebigRange.Select
    sortcell = ActiveCell.Address
    adresa = ActiveCell.Address(rowabsolute:=False, columnabsolute:=False)
    Range(sortcell).Select
    a = Range(sortcell).Text
    'nacitanie cisla tovaru podla riadku v ktorom sa nachadza aktivna bunka
    b1 = Cells(ActiveCell.Row, 1)
    b2 = Cells(ActiveCell.Row, 3)
    b3 = Cells(ActiveCell.Row, 4)
    b4 = Cells(ActiveCell.Row, 5)
    b = b1 + b2 + b3 + b4

    'nacitanie adresy sheet pre navrat
    currentSheet = ActiveSheet.Index
    ' zadanie dat na vyhladanie
    datatoFind = b
    'vyhladanie na sheete s menom z oznacenej bunky
    Sheets(a).Activate
    Cells.Find(What:=datatoFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate

    'nacitanie do premennej c adresy najdenej bunky
    c = ActiveCell.Address
    'navrat po hladani na povodny zosit
    Sheets(currentSheet).Activate
    Range(adresa).Activate

    'vytvorenie hyperlinku na subor "times" zosit "a" odkaz na bunku "c"
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="times.xlsx", _
    SubAddress:="'" & a & "'!" & c
   
Next RangebigRange

Application.ScreenUpdating = True
End Sub



[Azuzula]

Ahoj,
"trochu" jsem tvé makro zrevidovala, bude rychlejší.
Funkce je totožná, jen projde všechny označené buňky a provede tvoji proceduru. Nejsou ošetřené případné chyby!

Kód: Vybrat vše

Sub hypertext()
' hypertext Makro
'
' Klávesová skratka: Ctrl+h
'
'premenne
Dim rNalez As Range, rCell As Range, rRng As Range
Dim sNajit As Double
Dim iSh As Integer

'nastaví oblast
Set rRng = Selection
'nastaví index sheet pre navrat
iSh = ActiveSheet.Index

Application.ScreenUpdating = False
'začne hledání v každé buňce označené oblasti
For Each rCell In rRng.Cells
    If rCell <> "" Then 'provede na neprázdných buňkách
        'nacitanie cisla tovaru podla riadku v ktorom sa nachadza aktivna bunka
        sNajit = Cells(rCell.Row, 1)
        sNajit = sNajit + Cells(rCell.Row, 3)
        sNajit = sNajit + Cells(rCell.Row, 4)
        sNajit = sNajit + Cells(rCell.Row, 5)
               
        'vyhladanie na sheete s menom z oznacenej bunky
        Set rNalez = Sheets(rCell.Value).Cells.Find(What:=sNajit, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
       
        'vytvorenie hyperlinku na subor "times" zosit odkaz na bunku "rNalez"
        ActiveSheet.Hyperlinks.Add Anchor:=rCell, Address:=ThisWorkbook.Name, _
        SubAddress:="'" & rCell.Value & "'!" & rNalez.Address
    End If
Next
Application.ScreenUpdating = True
End Sub


--- Doplnění předchozího příspěvku (14 Bře 2014 12:10) ---

Tak cmuch byl rychlejší, ale nevadí, aspoň si můžeš vybrat :)

[fmb]

Dakujem za pomoc,
zaujimave riesenie... ale stihol som to vyriesit sedlickym rozumom, ked urobi hypertext tak sa posunie na bunku doprava ked je prazna posunie sa na zaciatok o riadok nizsie ked je ten prazdny posunie sa dalej cize ked drzim CTRL +H tak prebehne vsetky bunky za nejaky kratky cas a je to osefovane, tym padom som pokryl tych 2000 hypertextov :D:D ale to radsej nejdem postovat ten program lebo by som vyzeral nasmiech

[Azuzula]

Hlavní je, že si člověk umí poradit :)
Označ prosím téma za vyřešené.