Еще один ОПТИМИЗИРУЮЩИЙ макрос vba-код для Excel 2007. Код является своего рода транспонером для моих данных

Question

Здравствуйте, этот код был написан не мной изначально, и здесь есть некоторые признаки, которые я не совсем понимаю, я немного изменил его из кода моего коллеги, чтобы он соответствовал моим данным, и он работает.но слишком медленнои когда у меня есть 4000 + кб файлы Excel, он может полностью зависнуть.(Я проверил, что когда и после запуска этого транспонера он все еще будет в пределах строки Excel, я уже делал вычисления и создал макрос для автоматического разделения файлов Excel на основе количества столбцов и строк, чтобы убедиться, что это так),Этот код, кажется, запускается быстрее, а затем работает медленнее, чем дольше он работает.по крайней мере, это то, что мне нравится.

Не стесняйтесь предлагать любые способы сделать этот код быстрее / лучше!Спасибо за ваше время.Извините, что я не очень хорошо понимаю этот код.

я выключил обновление экрана, автоматический расчет и т. Д. И т. Д.

Dim InitRange As Range
Dim Counter As Range
Dim paracount As Long
Dim Filler As Range
Dim ParaSelect As Range
Dim Paraloc As Range
Dim Paravalloc As Range
Dim Unitloc As Range
Dim methodloc As Range
Dim CurNum As Long
Dim MaxNum As Long
Dim eCell As Range
Dim checkRow As Long
Dim InsertRow As Long
Dim x As Long
Dim y As Long
Dim vRow As Long

CurNum = 0
MaxNum = 0

x = 1

Range("K1").End(xlToRight).Offset(0, 0).Select

Set ParaSelect = Range("K1", ActiveCell)
InsertRow = ParaSelect.Count - 1

Set InitRange = Range("A4", "F4")
Set Counter = InitRange

Do
MaxNum = MaxNum + 1
InitRange.Offset(MaxNum, 0).Activate
Loop Until ActiveCell = ""


Set eCell = InitRange.Offset(0, 0)

Do
eCell.Offset(x, 0).Activate
Rows(eCell.Offset(x, 0).row & ":" & eCell.Offset(x, 0).row + InsertRow - 1).Insert
x = x + InsertRow + 1
If x > MaxNum * (InsertRow + 1) Then Exit Do
Loop

Range("A1").Activate

Set Filler = InitRange

Set Paraloc = Range("G4")
Set Paravalloc = Range("H4")
Set Unitloc = Range("I4")
Set methodloc = Range("J4")

vRow = 0
y = 0
Do

ParaSelect.Copy
Paraloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

ParaSelect.Offset(1, 0).Copy
methodloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

ParaSelect.Offset(2, 0).Copy
Unitloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

ParaSelect.Offset(CurNum * (InsertRow + 1) + 3, 0).Copy
Paravalloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

Filler.Offset(y, 0).Copy
CurNum = CurNum + 1
y = y + 1
checkRow = 1
Do
Filler.Offset(y, 0).PasteSpecial xlPasteValues
y = y + 1
Filler.Offset(y, 0).Activate
checkRow = checkRow + 1

Loop Until checkRow > InsertRow
Loop Until CurNum >= MaxNum

Джон сделал хорошее предложение g>.,Рисунок 1 - это то, как файл выглядит до его транспонирования

Рисунок 2 - это то, как файлы выглядят после его транспонирования.Не беспокойтесь, столбец k и после будет удален.

ПРИМЕЧАНИЕ. Файлы могут содержать любое количество столбцов и строк

Answer 1

Основная причина медленного кода - все ссылки на ячейки в циклах. Он будет работать намного быстрее, если вы скопируете данные в массив вариантов и поработаете над этим.

Шаги, которым вы должны следовать:

1. Определите диапазон исходных данных и установите для переменной Range значение

   Dim rngData as Range
Set rngData = Your Source Range

2. Скопировать данные

   Dim varSource as Variant
varSource = rngData

3. Рассчитать размер данных назначения и уменьшить размер массива вариантов до этого размера

   Dim varDestn() as variant
Redim varDestn(1 to NumberOfRows, 1 to NumberOfColumns)

4. Вычислить новые данные. Скопировать значения из varDource (строка, столбец) в varDestn (строка, столбец)

5. Удалить исходные данные (если требуется)

6. Поместить новые данные на лист

   Set rngData = Cells(1,1) _
.Resize(UBound(varDestn,1), UBound(varDestn,2)) _
.Offset(TopLeftCellRow, TopLeftCellCol)
rngData = varDestn

В целом количество ссылок на лист сводится к минимуму, особенно в циклах

Answer 2

Мне трудно точно понять, что вы пытаетесь сделать здесь без реальной рабочей тетради.Так что я сделал все возможное, надеюсь, ошибок нет.Если бы у меня была настоящая рабочая тетрадь или пример, я мог бы получить действительно хороший оптимизированный код.Вот мой первый проход:

    Dim InitRange As Range, Counter As Range, Filler As Range, ParaSelect As Range, Paraloc As Range
    Dim Paravalloc As Range, Unitloc As Range, methodloc As Range, eCell As Range
    Dim paracount As Long, CurNum As Long, MaxNum As Long, checkRow As Long, InsertRow As Long
    Dim x As Long, y As Long, vRow As Long

    CurNum = 0

    x = 1

    Set ParaSelect = Range("K1", Range("K1").End(xlToRight))
    InsertRow = ParaSelect.Count - 1

    Set InitRange = Range("A4", "F4")
    Set Counter = InitRange

    MaxNum = InitRange.Resize(1, 1).End(xlDown).row - 4

    Set eCell = InitRange

    'Not sure what you are trying to accomplish here so I'll the original code (except for non essential code.
    Do
        Rows(eCell.Offset(x, 0).row & ":" & eCell.Offset(x, 0).row + InsertRow - 1).Insert
        x = x + InsertRow + 1
        If x > MaxNum * (InsertRow + 1) Then Exit Do
    Loop

    Set Filler = InitRange

    Set Paraloc = Range("G4")
    Set Paravalloc = Range("H4")
    Set Unitloc = Range("I4")
    Set methodloc = Range("J4")

    vRow = 0
    y = 0

    Do

        ParaSelect.Copy
        Paraloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        ParaSelect.Offset(1, 0).Copy
        methodloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        ParaSelect.Offset(2, 0).Copy
        Unitloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        ParaSelect.Offset(CurNum * (InsertRow + 1) + 3, 0).Copy
        Paravalloc.Offset(y, 0).PasteSpecial xlPasteValues, Transpose:=True

        Filler.Offset(y, 0).Copy
        CurNum = CurNum + 1
        y = y + 1
        checkRow = 1
        Do
            Filler.Offset(y, 0).PasteSpecial xlPasteValues
            y = y + 1
            checkRow = checkRow + 1
        Loop Until checkRow > InsertRow
    Loop Until CurNum >= MaxNum

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

Sub TransposeIt()

    Dim i As Long, j As Long, k As Long
    Dim rData As Range
    Dim sData() As String, sName As String
    Dim wks As Worksheet
    Dim vData As Variant

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    'Initialize worksheets
    Set wks = ActiveSheet

    'Get data
    Set rData = wks.UsedRange
    vData = rData
    ReDim sData(1 To 10, 1 To rData.Columns.Count - 10)
    rData.Offset(1).Clear
    rData.Offset(10).Resize(1).Clear

    For i = 1 To UBound(vData)
        For j = 1 To UBound(sData)
            For k = 1 To 6
                sData(j, k) = vData(i, k)
            Next k
            sData(j, 7) = vData(1, j + 10)
            sData(j, 8) = vData(i, j + 10)
            sData(j, 9) = vData(3, j + 10)
            sData(j, 10) = vData(2, j + 10)
        Next j
        'Print transposed data
        wks.Range("A" & Application.Rows.Count).End(xlUp) _
           .Offset(1).Resize(UBound(sData), UBound(sData, 2)) = sData
    Next i

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub