另一个优化macros的VBA代码为Excel 2007.该代码是一种转置我的数据

你好这个代码最初并没有完成，这里有一些thigns我不明白我已经改变了一些从我的同事代码，以适应我的数据，它的工作原理。 但太慢了。 当我有4000 + kb的excel文件，它可能会完全冻结。 （我已经检查过，当这个转置器运行时，它仍然在excel行的限制内，我之前做过计算，并且根据列和行的数目自动分割excel文件，以确保这样做） 。 这段代码似乎开始快，然后越慢它运行的时间越长。 至less这对我来说似乎是件好事。

随意build议任何方法使此代码更快/更好！ 感谢您的时间。 对不起，我不明白这个代码超好。

我已closures屏幕更新，自动计算等

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提出了一个很好的build议。>我应该defiantely提供一些东西给你们看这个代码是关于什么的。 图片1是在转置之前的文件

图2是转置后的文件的样子。 不用担心列k，之后会被删除。

注意：文件可能有任意数量的行和列

Answer 1

如果没有实际的工作手册，我很难弄清楚你在做什么。 所以我尽了全力，希望没有错误。 如果我有实际的工作簿或例子，我可能会得到一个非常好的优化代码。 这是我的第一个传球：

  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 

好的，这应该是非常有效的。 确保你先testing一下，不知道我是否有任何偏移。

 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 

Answer 2

这个代码很慢的主要原因是循环中的所有单元格引用。 如果您将数据复制到一个变体数组并进行处理，它将运行得更快。

你应该遵循的步骤：

1. 计算源数据范围，并为此设置一个Rangevariables

   Dim rngData as Range
Set rngData = Your Source Range

2. 复制数据

   Dim varSource as Variant
varSource = rngData

3. 计算目标数据的大小并将variables数组的大小设置为该大小

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

4. 计算新的数据。 将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

通常保持对工作表的引用次数最less，特别是在循环中