VBA 代码不适用于大量迭代

Question

由于某种原因，当我将 for home = X to XX 循环设置为超过 10 次迭代时，此宏会冻结 EXCEL。

此代码将网页下载到 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