另一个用于excel 2007的OPTIMIZING宏vba代码。代码是我的数据的一种转换器

Question

你好这个代码本来不是我做的，这里有一些东西我不太明白我已经改变了一点我的同事代码，以适应我的数据，它的工作原理。但太慢了。当我有4000 + kb 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

Jon提出了一个很好的建议＆gt;。＆gt;我应该defiantely提供一些东西，告诉你们这个代码是什么。图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. Caluclate新数据。将值从varDource（row，col）复制到varDestn（row，col）

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