Another OPTIMIZING macro vba code for excel 2007.

Question

Hello this code was not done by me originally and there are some thigns here i dont quite understand i have altered it a bit from my coworkers code to suit my data and it works. but too slow. and when i have 4000+kb excel files it might freeze altogether. ( I have checked tho that when and after this transposer runs it will still be within the excel row limit, i had done calculations before and made a macro to automatically split excel files based on number of columns and rows to make sure this is so ). This code seems to start out fast then goes slower the longer it runs. at least this is what it seems liek to me.

Feel free to suggest any ways to make this code faster/better! Thank you for your time. Sorry that I dont understand this code super well.

i have turned off screen updating, automatic calculation, etc etc.

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 made a good suggestiong >.> i should defiantely provide something to show you guys what this code is about. Picture 1 is what the file looks like before it is transposed

Picture 2 is what the files looks like after it is transposed. No worries column k and after will be deleted.

NOTE: The files may have any number of columns and rows

Answer 1

The primary reason this code is slow is all the cell references in the loops. It would run much faster if you copied the data to a variant array and work on that.

Steps you should follow:

1. Work out the source data range, and set a Range variable to that

   Dim rngData as Range
Set rngData = Your Source Range

2. Copy the data

   Dim varSource as Variant
varSource = rngData

3. Calculate the size of the destination data and Dim a variant array to that size

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

4. Caluclate the new data. Copy values from varDource(row,col) to varDestn(row,col)

5. Delete the original data (if required)

6. Put the new data on the sheet

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

In general keep the number of references to the worksheet to a minimum, especially in loops

Answer 2

It's hard for me to figure out exactly what you are trying to do here without the actual workbook. So I did my best, hopefully there are no errors. If I had the actual workbook or an example I could probably get you a really nice optimized code. Here's my first pass:

    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

OK, this should be pretty efficient. Make sure you test it first, don't know if I got any of my offsets off at all.

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