Buna,
In lipsa unor detalii am presupus ca doriti indexarea unui fisier ales de dv, iar linkurile sa fie generate in fisierul selectat.
Aveti mai jos un cod modificat dupa cel initial care face urmatoarele:
- deschide fereastra de dialog pentru selectarea fisierului pe care doriti sa-l indexati
- verifica daca fisierul este deja deschis
- verifica daca fisierul are deja creata o foaie 'Cuprins' si daca da va intreaba daca doriti actualizarea ei
- daca foaia 'Cuprins' nu este gasita in fisier sau daca alegeti sa o actualizati, genereaza link-urile pentru fiecare foaie, la fel ca programul initial, cu diferentele urmatoare:
- - daca exista in foaie un link pentru 'Inapoi la Cuprins' ii pastreaza pozitia
- daca nu gaseste link de Inapoi... il creaza in celula A1 daca aceasta este 'Empty' sau in prima celula libera din randul 1 in celelalte cazuri
- daca fisierul selectat nu era deschis initial, il salveaza si il inchide.
Aveti in atasament un fisier exemplu a care codul este legat la un buton.
Codul se introduce intr-un Modul standard
Cod: Selectaţi tot
Sub Button1_Click()
Dim wb As Workbook
Dim wbName As String
Dim ws As Worksheet
Dim M As Long, i As Long, col As Long
Dim rLink As Range
Dim wbOpen As Boolean
M = 1
'Selectare workbook pentru indexat
wbName = Application.GetOpenFilename("Fisiere Excel , *.xl*", , "Selectati fisierul pentru care doriti indexarea foilor")
If wbName = "False" Then
MsgBox "Nu ati selectat nici un fisier pentru indexare"
Exit Sub
End If
'Verifica daca fisierul selectat este deschis
wbOpen = False
For Each wb In Workbooks
If wb.Name = Mid(wbName, InStrRev(wbName, "\", -1) + 1, Len(wbName)) Then
wbOpen = True
Exit For
End If
Next wb
Application.ScreenUpdating = False
If wb Is Nothing Then Set wb = Workbooks.Open(wbName)
'Verifica daca fisierul selectat are creata o foaie 'Cuprins'
For Each ws In wb.Worksheets
If ws.Name = "Cuprins" Then
i = MsgBox("Fisierul selectat contine deja o foaie 'Cuprins'" & vbNewLine _
& "Daca doriti actualizarea cuprisului apasati 'Yes'." & vbNewLine _
& "Daca nu doriti actualizarea lui sau daca foaia 'Cuprins' detine alte date, apasati 'No'.", _
vbYesNo + vbExclamation, "Actualizare Cuprins in fisierul " & wb.Name)
If i = vbNo Then
GoTo iesire
Else
Exit For
End If
End If
Next ws
'Actualizare 'Cuprins'
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(before:=wb.Sheets(1))
ws.Name = "Cuprins"
Else
If ws.Name <> "Cuprins" Then
MsgBox "Err. set ws"
GoTo iesire
End If
End If
With ws
.Cells(1, 1) = "Cuprins"
.Cells(1, 1).Name = "Index"
.Range("A2:A" & ws.Rows.Count).ClearContents
End With
For i = 1 To wb.Sheets.Count
If wb.Sheets(i).Name <> ws.Name Then
With wb.Sheets(i)
Set rLink = .Rows(1).Find(what:="Inapoi La Cuprins", LookIn:=xlValues, lookat:=xlWhole)
If rLink Is Nothing Then
If IsEmpty(.Range("A1")) Then
Set rLink = .Range("A1")
Else
Set rLink = .Cells(1, wb.Sheets(i).Columns.Count).End(xlToLeft).Offset(, 1)
End If
End If
M = M + 1
rLink.Name = "Start" & .Index
.Hyperlinks.Add Anchor:=rLink, Address:="", SubAddress:="Index", TextToDisplay:="Inapoi La Cuprins"
ws.Hyperlinks.Add Anchor:=ws.Cells(M, 1), Address:="", SubAddress:="Start" & .Index, TextToDisplay:=.Name
End With
End If
Next i
iesire:
If Not wbOpen Then wb.Close True
Set wb = Nothing
If Not ws Is Nothing Then Set ws = Nothing
End Sub
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.