Ошибка 1004 в диапазоне изменения размера и транспонирования массива

Question

Я не буду публиковать полный код, так как он довольно большой - я сосредоточусь на части, которая вызывает ошибку.

Макрос должен копировать URL, сгенерированные в Excel, открывать их в IE, копировать исходный код на другой лист, искать что-то в этом коде, сохранять результаты в определенной ячейке, удалять лист и переходить к следующему URL. Он работает довольно хорошо, он копирует исходные коды для многих URL, но для некоторых URL он просто не работает. Когда я открываю URL-адреса вручную - они работают отлично, но каким-то образом Excel выдает мне ошибку для них.

Не могли бы вы, ребята, проверить приведенную ниже информацию, чтобы помочь мне лучше понять, в чем проблема?

Вот два примера ссылок:

Этот работает хорошо - link1 Этот бросает ошибку 1004 - ссылка2

А вот и код:

    Sub CC_Check()

Dim ie As InternetExplorer
Dim html As HTMLDocument

Dim URL As Range
Dim Rng As Range
Dim ws1 As Worksheet

Set ws1 = Worksheets("One Code")

Set ie = New InternetExplorer

Set Rng = ws1.Range("A3:A18")

For Each URL In Rng

ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = ws1.Cells(URL.Row, 2).Value & "_" & ws1.Cells(6, 7).Value

ie.Visible = False
ie.navigate URL.Value

Do While ie.readyState <> READYSTATE_COMPLETE
DoEvents
Loop

Set html = ie.document

Range("A1").Value = html.DocumentElement.outerHTML

Dim arr

arr = Split(html.DocumentElement.outerHTML, vbLf)

Range("A1").Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr) '<-- this line causing error 1004

Answer 1

У Application.Transpose есть ряд проблем.Сбой, когда

• В массиве есть только один член (UBound(arr) = 1)
• Одна из строк имеет длину> 32 КБ (но я видел другие случаи, когда он уже не выполнялся, когдастрока имеет более 255 символов)
• Размер массива превышает 64 КБ (однако в Excel 2016 это не вызовет ошибку времени выполнения, а приведет к повреждению массива с меньшим размером

Таким образом, ставка заключается в том, чтобы выполнить преобразование вручную, что довольно просто. Кстати, вы должны использовать Worksheet -вариант для добавляемых листов - никогда не полагайтесь на Activesheet. Следующий код создаст новыйлист, только если он не существует (иначе он очистит его содержимое, так что вы можете запустить код несколько раз

Set newWs = Nothing
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(wsName)
On Error GoTo 0
If newWs Is Nothing Then
    ' Sheet doesn't exist, create a new one and name it
    Set newWs = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    newWs.Name = ws1.Cells(URL.row, 2).Value & "x" & ws1.Cells(6, 7).Value
Else
    ' Sheet already there, clear its content
     newWs.UsedRange.ClearContents
End If

    (..Load HTML and split..)

' Do your own transpose into a 2nd array and dump that into sheet
Dim brr
ReDim brr(LBound(arr) To UBound(arr), 1 To 1)  ' Make it 2-dimensional
Dim i As Long
For i = LBound(arr) To UBound(arr)
    brr(i, 1) = arr(i)
Next i
Range("A1").Resize(UBound(arr) + 1, 1).Value = brr