Ešte by sa to dalo celé riešiť napr aj takto :
Sub AktualizujHyp()
Dim Bunka As Range, H As String, R As Long
Dim EXA As Excel.Application, WB As Workbook, WS As Worksheet
Set EXA = CreateObject("Excel.Application")
Set WB = EXA.Workbooks.Open(Application.ThisWorkbook.Path & "\data.xlsx")
Set WS = WB.Worksheets("Hárok1")
R = WS.Range("A:D").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With ThisWorkbook.Worksheets("Hárok1")
With .Range("A:D")
.ClearContents
.Resize(R) = WS.Range("A:D").Resize(R).Value
End With
WB.Close False
Set EXA = Nothing
If R = 1 Then Exit Sub
For Each Bunka In .Cells(2, 4).Resize(R - 1)
If Not IsEmpty(Bunka) Then
With Bunka
H = .Value
H = IIf(Left(H, 4) = "http", "", "http://") & H
With .Hyperlinks
If .Count = 0 Then .Add anchor:=Bunka, Address:=H Else Bunka.Hyperlinks(1).Address = H
End With
End With
End If
Next Bunka
End With
End Sub
Predošlé makro doplnené a zaujímavý spôsob prístupu do zatvoreného súboru od Paloo, čerpané odtiaľto:
http://wall.cz/index.php?m=topic&id=24364#post-24377
Treba to ale ešte zabezpečiť na odchyt chýb, pretože to vytvára samostatnú aplikáciu Excel (skrytú), a akonáhle príde k nejakej chybe, tak tento druhý Excel ostane visieť s alokovanými zdrojmi, teda aj zamknutým data.xlsx pre zápis.
V tomto prípade by možno šlo použiť aj Copy Paste, a nemusia sa potom upravovať linky v prípade, že sú to http linky, a nie len www. Mne totiž www neotvorí, iba http. Takže ak to nieje len nesprávnym nastavením môjho Excelu, a chcete mať zobrazené názvy linkov tak ako ich máte, potom treba urobiť aj tú spodnú časť kódu.
EDIT:
Tak toto je metóda, ako skopírovať celú použitú oblasť z data.xlsx aj s formátovaním a hyperlinkami proste tak ako to je v data.xlsx. Ale ako som spomínal, treba zvážiť počet plánovaných riadkov, či nebude lepšie použiť Excel4Makro a počet riadkov mu určí schovaný vzorec s COUNTA, alebo presypať cez Value, alebo vložiť vzorec, a upraviť Hyperlinky bunku po bunke.
Sub Aktualizuj()
Dim EXA As Excel.Application
Set EXA = CreateObject("Excel.Application")
With EXA.Workbooks.Open(Application.ThisWorkbook.Path & "\data.xlsx").Worksheets("Hárok1").Range("A:D")
.Resize(.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row).Copy
Windows("prepojenie.xlsm").Activate
With ThisWorkbook.Worksheets("Hárok1").Range("A:D")
.Clear
.Cells(1, 1).Activate
Application.CutCopyMode = False
ActiveSheet.Paste
.Cells(1, 1).Select
End With
End With
Set EXA = Nothing
End Subcitovat