Macro voor het maken van een Index van alle sheets in het bestand

[scartsjer]

Hallo,

Eerder heeft HSV mij geholpen in dit topic: Klik

het resultaat van dit eerdere topic werkt uitstekend (in bijgevoegd bestand Module 3 aan te roepen met ctrl+L)

Nu ben ik een soortgelijke code aan het maken om de index sheet te vullen. Vanaf cel A9:C9 moet de de waarde van elke sheet B1, B2, B3 naast elkaar worden gezet. beginnend bij de eerste sheet.

Hierbij worden de sheet Front, Index, Summary uitgesloten van deelname.

Tegelijkertijd met het indexeren wordt ook de naam van de sheet hernoemd naar de inhoud van cel B1.

Het hernoemen werkt goed, ik heb alleen het probleem dat alleen de laatste toegevoegde waardes in de array worden geprint.

wie kan mij hierbij helpen?

in het bijgevoegde bestand gaat het om module 2 welke aan te roepen is met Ctrl+K

Sub Sheetname()
'
' Sheetname Macro
' ctrl+K
'
'
Dim strOrderno As Object, strdescription As Object, strBauhuisref As Object, sh As Worksheet, sn, i As Long
Set strOrderno = CreateObject("Scripting.Dictionary")
Set strdescription = CreateObject("Scripting.Dictionary")
Set strBauhuisref = CreateObject("Scripting.Dictionary")
For Each sh In Sheets
    If sh.Name <> "Index" And sh.Name <> "Summary" And sh.Name <> "Template" And sh.Name <> "Front" Then
            If i <= 0 Then i = i + 1
            If i >= 0 Then
                Sheets(sh.Name).Select
                strOrderno(i) = Range("B1").Value
                strdescription(i) = Range("B2").Value
                strBauhuisref(i) = Range("B3").Value
                'Wijzig de sheetname naar de inhoud van cel B1
                ActiveSheet.Name = strOrderno(i)
    End If
    End If
Next sh
  With Sheets("Index")
     .Range("A9:C" & Application.Max(3, .Cells(Rows.Count, 1).End(xlUp).Row)).ClearContents
     .Range("A9").Resize(strOrderno.Count, 3).Value = Application.Transpose(Array(strOrderno.items, strdescription.items, strBauhuisref.items))
  End With
  '
  Sheets("Index").Select
'
End Sub

 

[scartsjer]

Ik krijg dit probleem niet opgelost, is er iemand die mij kan helpen?

 

[scartsjer]

probleem is opgelost via een ander forum.
resultaat:

Sub M_snb()
   With CreateObject("Scripting.Dictionary")
     For Each sh In Sheets
       If InStr("_Index_Summary_Template_Front_", "_" & sh.Name & "_") = 0 Then
          .Item(.Count) = application.transpose(sh.Range("B1:B3"))
          sh.Name = sh.Range("B1").Value
       End If
     Next
    
     Sheets("Index").Range("A9:C9").Resize(100).ClearContents
     Sheets("Index").Range("A9:C9").Resize(.Count) = Application.Index(.Items, 0, 0)
  End With
End Sub