How to get sheets Name from index sheet and use them in array with VBA

[allam2002]

I have a Table in sheet "index" with column "Company" and i have a sheet for each company with the same name so i want to create a code with vba to get the companies names from this column and use it in array, i tried this code
Dim DirArray() As Variant
DirArray = Sheets("index").Range("B2:B5").Value
For Each sh In ActiveWorkbook.Sheets(DirArray(1, 1))

but i got an error so what is wrong and if i want to expand the Range limit to the last cell with value,
Can you please help me and if i want to use ListObjects to get the data from this Table can you point me to the right way.

Thank You

 

[allam2002]

Here is my Whole Code

Sub CopyDataWithoutHeaders()
    Dim i As Long
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
    Dim rngMyUsedRange As Range
    Dim rCell As Range
    Dim DirArray As Variant
   ' DirArray = Sheets("setting").Range("A2:A5")
    DirArray = Sheets("setting").Range("A2", Sheets("setting").Cells(Rows.Count, "A").End(xlUp))
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    'Delete the sheet "Alert" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Alert").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    'Add a worksheet with the name "Alert"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Alert"
    'Fill in the start row
    StartRow = 3
    
    lnDestRow = DestSh.Cells(DestSh.Rows.Count, "A").End(xlUp).Row + 1
    
    'loop through all worksheets and copy the data to the DestSh
    For i = LBound(DirArray) To UBound(DirArray)
   
    
   Set sh = ActiveWorkbook.Sheets(DirArray(i, 1))
        'Copy header row, change the range if you use more columns
	lnDestRow = lnDestRow + 1
 	 sh.Range("A1:P1").Copy DestSh.Range("A" & lnDestRow)
	lnDestRow = lnDestRow + 1
	sh.Range("A2:P2").Copy DestSh.Range("A" & lnDestRow)
	lnDestRow = lnDestRow + 1


            'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)


 
     For Each rCell In sh.Range("I3:I100,L3:L100,M3:M100")


           
            If IsDate(rCell.Value) _
        And rCell.Value < Date + 30 Then


                sh.Rows(rCell.Row).Copy
                With DestSh.Range("A" & lnDestRow)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
                lnDestRow = lnDestRow + 1
            End If
        Next rCell
         
      
     
    Next i


ExitTheSub:


    Application.Goto DestSh.Cells(1)


    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub

When i use this line
DirArray = Sheets("setting").Range("A2:A5")
it works good
Note: i changed the the sheet name and the column

 

[Rick Rothstein]

What line is highlighted in yellow when you get the subscript out of range error?

 

[allam2002]

Nothing is highlighted in yellow . the code is working until it finds an empty cell and exit with error

 

[Rick Rothstein]

Nothing is highlighted in yellow . the code is working until it finds an empty cell and exit with error

Hmm, I think maybe I was interpreting a comment you made to someone else (Message #9 ) as if it were meant for me and the code suggestion I posted in Message #8 , hence, my question back to you. You should consider mentioning the name of who you are responding to in your messages when you have more than one responder. Anyway, as to your current problem... it is kind of hard to trace without having your actual workbook here so that we can follow what the code is doing with it as it executes. Any chance you can post a copy of your workbook to DropBox or some other free file sharing website so that we can download it and test your code in it?

 

[allam2002]

Thank you Rick Rothstein here is the link to the file but i am sorry that the file data is in Arabic language

Dropbox - Testing.xlsm

 

[allam2002]

Sorry i posted a wrong file , here is the right one
Dropbox - Testing.xlsm