Так что на работе я работаю над макросом / UserForm в Excel для кого-то. Он отлично работает (я думаю) и делает именно то, что ему нужно, и занимает менее 1 минуты, чтобы пройти, пройдя ~ 70 тыс. Ячеек и организовав их. Теперь мне было интересно, есть ли способ замедлить его, чтобы Excel не переходил в режим «Не отвечает» во время работы. Было бы лучше, чтобы люди, которым нужно использовать макрос, не волновались, когда он зависал. И было бы лучше, если бы в VBA было решение, чтобы люди не беспокоились об этом, и оно работает отлично с первого раза.

О макросе

Данные представляют собой набор чисел, которые должны быть помещены в один столбец, и в 14 (обычно 14) столбцах перед ним каждый номер помечается датами и другими данными. Все ссылки на размеры и имена листов должны быть из пользовательской формы, поэтому я заранее не знаю ни имени листов, ни размера, что привело к некоторому странному коду в начале моего цикла.

Кроме того, если вы все равно захотите сделать мой код более эффективным, это будет с благодарностью!

Код

Private Sub UserForm_Initialize()

    'This brings up the data for my dropdown menu to pick a sheet to pull data from
    For i = 1 To Sheets.Count
        combo.AddItem Sheets(i).name
    Next i

End Sub

Private Sub OK_Click()

    Unload AutoPivotusrfrm

    'Declaring All of my Variables that are pulled from Userform

    Dim place As Long

    Dim x1 As Integer
    x1 = value1.Value
    Dim x2 As Integer
    x2 = value2.Value
    Dim x3 As Integer
    x3 = value4.Value
    Dim y1 As Integer
    y1 = value3.Value

    Dim copyRange As Variant

    Dim oldname As String
    oldsheetname = combo.Text

    Dim newname As String
    newname = newsheetname.Text

    Sheets.Add.name = newsheetname

    'Labels for section one
    Worksheets(CStr(oldsheetname)).Activate
    copyRange = Range(Cells(x1, x1), Cells(x1 + 1, x3 - 1)).Value
    Worksheets(CStr(newsheetname)).Activate
    Range(Cells(x1, x1), Cells(x1 + 1, x3 - 1)).Value = copyRange
    place = x1 + 2
    x1 = place


    'Looping through the cells copying data
    For i = x1 To x2
    'This was the only way to copy multiple cells at once other ways it would just error
        Worksheets(CStr(oldsheetname)).Activate
        copyRange = Range(Cells(i + 3 - x1, x1 - 2), Cells(i + 3 - x1, x3 - 1)).Value
        Worksheets(CStr(newsheetname)).Activate
        For j = x3 To y1
            Range(Cells(place, 1), Cells(place, x3 - 1)).Value = copyRange
            Cells(place, x3) = Sheets(CStr(oldsheetname)).Cells(1, j)
            Cells(place, x3 + 1) = Sheets(CStr(oldsheetname)).Cells(2, j)
            Cells(place, x3 + 2) = Sheets(CStr(oldsheetname)).Cells(i + 2, j)
            place = place + 1
        Next j
    Next i

End Sub

Private Sub cancel_Click()

    Unload AutoPivotusrfrm

End Sub