Cum se...afiseaza indexul unui workbook Excel

trucuri, sfaturi si alte idei pentru imbunatatirea lucrului cu Excel
Catalin B.
Moderator
Moderator
Mesaje: 813
Membru din: Vin Sep 09, 2011 4:05 pm
Localitate: Iaşi

Re: Cum se...afiseaza indexul unui workbook Excel

Mesaj de Catalin B. » Dum Feb 10, 2013 1:51 pm

Indigo scrie:Numarul maxim de foi este 200 :lol:
De unde stii asta?
Limita este data doar de resursele din sistem...
Poti sa incerci sa rulezi de cateva ori si :

Cod: Selectaţi tot

Sub WksAdd()
Dim i As Integer
For i = 1 To 600
Worksheets.Add
Next i
End Sub
Probleme să fie, că soluţii se găsesc...

Indigo
Mesaje: 774
Membru din: Sâm Sep 26, 2009 8:05 pm

Re: Cum se...afiseaza indexul unui workbook Excel

Mesaj de Indigo » Dum Feb 10, 2013 2:51 pm

Catalin B. scrie:
Indigo scrie:Numarul maxim de foi este 200 :lol:
De unde stii asta?
Limita este data doar de resursele din sistem...
Poti sa incerci sa rulezi de cateva ori si :

Cod: Selectaţi tot

Sub WksAdd()
Dim i As Integer
For i = 1 To 600
Worksheets.Add
Next i
End Sub
Eu raspunsesem ca idee, ca sa mai si poti lucra in el...
Asa este de inserat poti insera probabil si 1000 dar ar avea probabil cateva zeci de Mb sau peste 100 Mb daca mai ai si date in ele (nu mai spun de formatari si/sau formule) probabil ca iti trebuiesc serverele de la Google sa-l deschizi :lol:

miirceabarbu
Mesaje: 59
Membru din: Vin Sep 03, 2010 8:50 am

Re: Cum se...afiseaza indexul unui workbook Excel

Mesaj de miirceabarbu » Joi Iun 08, 2017 8:21 am

Buna ziua,
Cum ar putea acest cod sa indexeze sheet-urile din alt fisier?
Mutumesc!

TudyBTH
Moderator
Moderator
Mesaje: 993
Membru din: Joi Feb 11, 2016 2:12 pm
Localitate: Cluj Napoca

Re: Cum se...afiseaza indexul unui workbook Excel

Mesaj de TudyBTH » Joi Iun 08, 2017 1:14 pm

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.
Am invatat sa inotam in apa, ca pestii
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.

Închis

Înapoi la “Tips and Tricks Excel”