add to array but unsure how to fill it

[KDS14589]

Each of my worksheets have a two part name (Division).(Purpose), such as Domain.Switchboard

I've been trying to get the first part of the name (Domain) before the separator "." and separately the second part (Purpose) after the separator ".".

I've tried formulas I have for this purpose; they work fine on individual worksheets but the VBA debugger gets mad at 'filename'.

My latest attempt is to increase the array from 4 to 6 as in SbG.Cells(rG, CodeNameClmG).Resize(, 4).Value = Array(WsG.CodeName, WsG.Name, WsG.Index, WsG.Visible, WsG.Division, WsG.Purpose) but I don’t know what to use in WsG.Division & WsG.Purpose

With this latest attempt I even Dim As String both Domain & Purpose but NNNNNNOOOOOO

Help will be appreciated with this or point me in correct path.

This code I'm sending doesn’t include some of these changes because with those changes the results disappear. The picture is from before those changes.

 Cells.Range("D5:G104").ClearContents
    
    Const SwitchBoardName As String = "general.misc"
    Const FilterCell As String = "b5"
    Const OutputRow As Long = 5
    Const IndexClm As String = "c"
    Const NameClm As String = "d"
    Const VisibleClm As String = "h"
    Const CodeNameClm As String = "e"
    
    Dim Sb As Worksheet
    Dim Flt As String
    Dim TabNames() As String
    Dim r As Long
    Dim ws As Worksheet
    Dim rng As Range
    
    Set Sb = ThisWorkbook.Worksheets(SwitchBoardName)
    Flt = Sb.Range(FilterCell).Cells(1).Value
    ReDim TabNames(ThisWorkbook.Worksheets.Count)
    
        r = OutputRow
        [e4] = [{"Name"}]
        [f4] = [{"CodeName"}]
        [d4] = [{"Index"}]
        [g4] = [{"Visibility"}]
        [l1] = [{"Restricted Worksheets"}]
        [H4] = [{"Division"}]
        [I4] = [{"Purpose"}]
        
    ''''order by [index] accending by Fluff @ Mr Excell
    
        For Each ws In ThisWorkbook.Worksheets
            If InStr(1, ws.Name, Flt, vbTextCompare) = 1 Then
            Sb.Cells(r, NameClm).Resize(, 4).Value = Array(ws.Index, ws.Name, ws.CodeName, ws.Visible)
            r = r + 1
            End If
            Next ws
        
        If r Then
            Set rng = Sb.Range(Sb.Cells(OutputRow, NameClm), Sb.Cells(r - 1, NameClm))
            With Sb.Sort
            With .SortFields
            .Clear
            .Add Key:=rng.Cells(1), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, _
            DataOption:=xlSortTextAsNumbers
            End With
        .SetRange rng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

 

[KDS14589]

Ahh I see @Rick Rothstein you were going off of column E results and using that approach, yeah, I can see that approach. Probably a better, simpler, approach. Would save a line of code.

My original code that I'm sending produced a list of worksheets and their properties. Also see picture Mr Excel 3 8.28.21

Cells.Range("D5:G104").ClearContents



Const SwitchBoardName As String = "general.misc"

Const FilterCell As String = "b5"

Const OutputRow As Long = 5

Const IndexClm As String = "c"

Const NameClm As String = "d"

Const VisibleClm As String = "h"

Const CodeNameClm As String = "e"



Dim Sb As Worksheet

Dim Flt As String

Dim TabNames() As String

Dim r As Long

Dim ws As Worksheet

Dim rng As Range



Set Sb = ThisWorkbook.Worksheets(SwitchBoardName)

Flt = Sb.Range(FilterCell).Cells(1).Value

ReDim TabNames(ThisWorkbook.Worksheets.Count)



r = OutputRow

[e4] = [{"Name"}]

[f4] = [{"CodeName"}]

[d4] = [{"Index"}]

[g4] = [{"Visibility"}]

[l1] = [{"Restricted Worksheets"}]

[H4] = [{"Division"}]

[I4] = [{"Purpose"}]



''''order by [index] accending by Fluff @ Mr Excell



For Each ws In ThisWorkbook.Worksheets

If InStr(1, ws.Name, Flt, vbTextCompare) = 1 Then

Sb.Cells(r, NameClm).Resize(, 4).Value = Array(ws.Index, ws.Name, ws.CodeName, ws.Visible)

r = r + 1

End If

Next ws



If r Then

Set rng = Sb.Range(Sb.Cells(OutputRow, NameClm), Sb.Cells(r - 1, NameClm))

With Sb.Sort

With .SortFields

.Clear

.Add Key:=rng.Cells(1), _

SortOn:=xlSortOnValues, _

Order:=xlAscending, _

DataOption:=xlSortTextAsNumbers

End With

.SetRange rng

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Each worksheet has a two-part name.

The first part (Division) is before the separator (.)

The second part (Purpose) is after the separator (.)

Such as Index 1 worksheet name Domain.Switchboard in column E; Domain is the Division & Switchboard is the Propose

I'm trying to each worksheets Division (Domain) in column H & their Purpose (Switchboard) in column I

See Mr Excel 2 8.28.21 picture attachment of what I'm trying.



The picture Mr Excel 1 8.28.21 attachment is with @Rick Rothstein code modification such as this code

Cells.Range("D5:G104").ClearContents



Const SwitchBoardName As String = "general.misc"

Const FilterCell As String = "b5"

Const OutputRow As Long = 5

Const IndexClm As String = "c"

Const NameClm As String = "d"

Const VisibleClm As String = "h"

Const CodeNameClm As String = "e"



Dim Sb As Worksheet

Dim Flt As String

Dim TabNames() As String

Dim r As Long

Dim ws As Worksheet

Dim rng As Range



Set Sb = ThisWorkbook.Worksheets(SwitchBoardName)

Flt = Sb.Range(FilterCell).Cells(1).Value

ReDim TabNames(ThisWorkbook.Worksheets.Count)



r = OutputRow

[e4] = [{"Name"}]

[f4] = [{"CodeName"}]

[d4] = [{"Index"}]

[g4] = [{"Visibility"}]

[l1] = [{"Restricted Worksheets"}]

[H4] = [{"Division"}]

[I4] = [{"Purpose"}]



''''order by [index] accending by Fluff @ Mr Excell



' '

Dim Division As String

Dim Purpose As String

Dim ThisSheetName As String



ThisSheetName = ActiveSheet.Name ' Get sheet name







For Each ws In ThisWorkbook.Worksheets

If InStr(1, ws.Name, Flt, vbTextCompare) = 1 Then

Sb.Cells(r, NameClm).Resize(, 4).Value = Array(ws.Index, ws.Name, ws.CodeName, ws.Visible)

r = r + 1

End If

Next ws

Intersect(Columns("H:I"), Rows("1:" & Rows.Count)).ClearContents

Range("E5", Cells(Rows.Count, "E").End(xlUp)).TextToColumns Range("H5"), xlDelimited, , , False, False, False, False, True, "."





If r Then

Set rng = Sb.Range(Sb.Cells(OutputRow, NameClm), Sb.Cells(r - 1, NameClm))

With Sb.Sort

With .SortFields

.Clear

.Add Key:=rng.Cells(1), _

SortOn:=xlSortOnValues, _

Order:=xlAscending, _

DataOption:=xlSortTextAsNumbers

End With

.SetRange rng

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

But now each time I 'refresh' the worksheet or enter it from another worksheet it asks me if I want to replace the existing data!

 

[Rick Rothstein]

I do not see how that could be happening because of my code... the first line of my code clears the cells that TextToColumns is going to populate... it does that clearing in order to stop the message you are getting from happening. What may be happening is some kind of reentrance of the code. You have a Change event procedure in your project, correct? If so, are you disabling events at its beginning and re-enabling events at the end?

 

[KDS14589]

I do not see how that could be happening because of my code... the first line of my code clears the cells that TextToColumns is going to populate... it does that clearing in order to stop the message you are getting from happening. What may be happening is some kind of reentrance of the code. You have a Change event procedure in your project, correct? If so, are you disabling events at its beginning and re-enabling events at the end?

Never mind I got it all working Now, THANKS for the help

 

[smozgur]

Never mind I got it all working Now, THANKS for the help

Please mark the post as solution that solved your problem instead of your "closure" post. If you solved your problem yourself, then post your own solution, then you can mark your own post as the solution.

 

[KDS14589]

Please mark the post as solution that solved your problem instead of your "closure" post. If you solved your problem yourself, then post your own solution, then you can mark your own post as the solution.

i thought i did
I'll do it again
i used Rick Rothstein solution