Код VBA не работает для большого количества итераций

Question

По какой-то причине этот макрос замораживает EXCEL, когда я устанавливаю цикл for home = X-XX в более чем 10 итераций.

Этот код загружает веб-страницу в excel, извлекает ячейки, которые содержат «общий» или «переносимый», и копирует их на другой лист в той же книге.

Спасибо

Sub Macro1() 
' 
' Macro1 Macro 
' 

' 

Dim home    As Integer 

Dim Calc_sheet   As Worksheet 

Dim score_count   As Integer 
Dim inspection_count As Integer 

Dim output_rows   As Integer 
Dim output_columns  As Integer 
Dim date_columns  As Integer 


'Counting variables 
score_count = 3 
inspection_count = 8 

'Output rows and columns starting values 
output_rows = 3 
output_columns = 3 
date_columns = 8 

For home = 20 To 23 

With ActiveSheet.QueryTables.Add(Connection:= _ 
    "URL;http://www.XXXXXXXX.org.uk/directory/" & Sheets("Output").Cells(home, 1), Destination:=Range("$A$1") _ 
    ) 
    '.CommandType = 0 
    .Name = "Homes" 
    .FieldNames = True 
    .RowNumbers = False 
    .FillAdjacentFormulas = False 
    .PreserveFormatting = True 
    .RefreshOnFileOpen = False 
    .BackgroundQuery = True 
    .RefreshStyle = xlInsertDeleteCells 
    .SavePassword = False 
    .SaveData = True 
    .AdjustColumnWidth = True 
    .RefreshPeriod = 0 
    .WebSelectionType = xlEntirePage 
    .WebFormatting = xlWebFormattingNone 
    .WebPreFormattedTextToColumns = True 
    .WebConsecutiveDelimitersAsOne = True 
    .WebSingleBlockTextImport = False 
    .WebDisableDateRecognition = False 
    .WebDisableRedirections = False 
    .Refresh BackgroundQuery:=False 
End With 



    For x = 20 To 250 
     Select Case Left(Cells(x, 1), 7) 

     'Is it a score? 
     Case Is = "Overall" 
      Cells(x, 1).Copy 
      Sheets("Output").Select 
      Cells(output_rows, output_columns).Select 
      ActiveSheet.Paste 
      output_columns = output_columns + 1 

     'Is it a date? 
     Case Is = "Carried" 
      Cells(x, 1).Copy 
      Sheets("Output").Select 
      Cells(output_rows, date_columns).Select 
      ActiveSheet.Paste 
      date_columns = date_columns + 1 

     Case Else 

     End Select 

     Sheets("Calc_sheet").Activate 
     Cells(x, 1).Activate 

    Next x 
'Clean sheet 
ActiveSheet.Cells.Delete 

'Go back to top 
Range("A1").Select 

'Reset column count 
output_columns = 3 
date_columns = 8 

output_rows = output_rows + 1 
Next home 


End Sub 

Answer 1

Я обновил код, попробуйте еще раз!

Попробуйте заменить внутреннюю петлю с этим:

Dim wsC As Worksheet 
Dim wsO As Worksheet 

Set wsC = Worksheets("Calc_sheet") 
Set wsO = Worksheets("Output") 

For x = 20 To 250 

    yourContent = wsC.Cells(x, 1) 
    yourCase = Left(yourContent, 7) 

    Select Case yourCase 

    'Is it a score? 
    Case Is = "Overall" 
     wsO.Cells(output_rows, output_columns) = yourContent 
     output_columns = output_columns + 1 

    'Is it a date? 
    Case Is = "Carried" 
     wsO.Cells(output_rows, date_columns) = yourContent 
     date_columns = date_columns + 1 

    Case Else 

    End Select 

Next x