Das Kopieren von dynamischem Array führt zu einem außerhalb des Bereichs liegenden Fehler

Question

Ich versuche, Arbeitsblätter aus einer Arbeitsmappe in eine Zielarbeitsmappe zu kopieren, aber die Arbeitsblätter, die ich kopiere, sind abhängig davon, ob der Wert in rngCurrent im Arbeitsblattnamen vorhanden ist. Aus irgendeinem Grund bekomme ich in der letzten Zeile immer einen Indexfehler oder Bereichsfehler. Kann mir jemand helfen zu verstehen, was vor sich geht?

Sub test2() 
Dim wb As Workbook 
Dim master As Workbook 
Dim wbCurrent As Workbook 
Dim wbAdjustments As Workbook 
Dim wsName As Worksheet 
Dim rngEntityList As Range 
Dim rngCurrentEntity As Range 
Dim rngCurrent As Range 
Dim arrWorksheets As Variant 
Dim i As Integer 
Dim wsCount As Integer 

Set master = ThisWorkbook 


Set rngCurrentEntity = master.Sheets("File Info").Range("rng_Entity") 'named range of single entity 

Set rngEntityList = master.Sheets("Global").Range("rng_EntityList") 'list or entities 

Set rngCurrent = rngEntityList.Find(rngCurrentEntity.Value, LookIn:=xlValues) ' find single entity in the list 

If rngCurrent.Offset(, 4).Value = "FRP" Then 'find if it's FRP 
Set wb = Application.Workbooks("Foreign.xlsx") 

Else 
Set wb = Application.Workbooks("Domestic.xlsx") 

End If 

Dim ws() As String ' declare string array 
ReDim ws(wb.Worksheets.Count) As String ' set size dynamically 

Dim counter As Long ' running counter for ws array 
counter = 1 



For i = 1 To wb.Worksheets.Count 
    If InStr(1, wb.Worksheets(i).Name, rngCurrent.Value) <> 0 Then 
     ws(counter) = wb.Worksheets(i).Name 
     counter = counter + 1 
    End If 
    Next 

    ReDim Preserve ws(counter) As String ' Get rid of empty array entries 

    wb.Worksheets(ws).Copy After:=master.Worksheets(master.Worksheets.Count) 

End Sub 

EDIT Der Grund ich brauche, ist es auf diese Weise zu tun, weil ich nicht die externen Links auf die Quelle Notebook möchten.

Answer 1

und komplette Beispiel getestet

Sub Tester() 

    Dim wb As Workbook, i As Long 
    Set wb = ThisWorkbook 

    Dim ws() As String ' declare string array 
    ReDim ws(1 To wb.Worksheets.Count) As String ' set size dynamically 

    Dim counter As Long ' running counter for ws array 
    counter = 0 

    For i = 1 To wb.Worksheets.Count 
     If InStr(1, wb.Worksheets(i).Name, "test") <> 0 Then 
      counter = counter + 1 
      ws(counter) = wb.Worksheets(i).Name 
     End If 
    Next 

    ReDim Preserve ws(1 To counter) 

    wb.Worksheets(ws).Copy 'just makes a copy in a new workbook 

End Sub 

Answer 2

dies tun:

ReDim ws(1 To wb.Worksheets.count) As String ' set size dynamically, start from 1 
Dim counter As Long ' running counter for ws array 

For i = 1 To wb.Worksheets.count 
    If InStr(1, wb.Worksheets(i).name, rngCurrent.Value) <> 0 Then 
     counter = counter + 1 '<--| update counter 
     ws(counter) = wb.Worksheets(i).name 
    End If 
Next