Копирование динамического массива вызывает ошибку подстрочного индекса

Я пытаюсь скопировать рабочие листы из основной книги в целевую книгу, но скопированные мной листы различаются в зависимости от того, присутствует ли значение в rngCurrent в имени листа. По какой-то причине я продолжаю получать индекс или ошибку диапазона на последней строке. Может ли кто-нибудь помочь мне понять, что происходит?Копирование динамического массива вызывает ошибку подстрочного индекса

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 Причина мне нужно сделать это таким образом, потому что я не хочу, чтобы внешние ссылки на источник ноутбука.

источник

2017-01-20 Olu O.

какой линии вы получаете свою ошибку? –

По умолчанию нижняя граница массива равна нулю, а не одному. Ваша ошибка связана с отсутствием содержимого в 0-м слоте в вашем массиве. Попробуйте 'ReDim ws (от 1 до wb.Worksheets.Count)' (указав как верхнюю, так и нижнюю границы без 'As String') –

@ShaiRado Я получаю сообщение об ошибке на странице wb.Worksheets (ws) .Copy –

Полный и проверенный пример

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

источник

2017-01-20 07:29:33

Я как раз собирался опубликовать, что я понял. Благодаря! Я бы никогда не подумал об обновлении счетчика. –

сделать это:

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

источник

2017-01-20 07:10:00 user3598756

Я пробовал это, но теперь он дает мне ошибку в строке 'ReDim Preserve'. –

redim должен быть 'ReDim Preserve ws (1 to counter) As String' – user3598756

Копирование динамического массива вызывает ошибку подстрочного индекса

ответ

Смежные вопросы