另一個優化的宏VBA代碼爲Excel 2007年。代碼是一種轉換器爲我的數據

Question

你好這個代碼不是我最初做的，有一些thigns在這裏我不太明白我已經改變了它從我的同事有點代碼，以適應我的數據，它的工作原理。但太慢了。當我有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 

喬恩取得了良好的suggestiong>>我要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 

好的，這應該是非常有效的。確保你先測試它，不知道我是否有任何偏移。

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. 工作出源數據範圍和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（行，列）到varDestn（行，列）

5. 刪除原始數據（如果需要）

6. 拷貝值把片

   Set rngData = Cells(1,1) _
.Resize(UBound(varDestn,1), UBound(varDestn,2)) _
   上的新數據 .Offset(TopLeftCellRow, TopLeftCellCol)
rngData = varDestn

通常保持對工作表的引用數量降到最低，尤其是在循環中