Excel VBA Optimization - Transposing Data

I've receieved a report in a rolled up fashion in Excel that I need to flatten out in order to import it into Access. Here's a sample of the row:

What needs to happen is the Customer Account and Name need to be transposed to be adjacent to the Voucher line, and needs to be copied so each voucher line has this information. After the transformation, the data should look like this:

Customer Account |  Name  | Date | Voucher | Invoice | Transation Text | Currency

Note that the row starting with "USD" denotes the end of records for that customer.

I have successfully implemented the following code:

Sub Process_Transactions()
'turn off some Excel functionality so code runs faster
Application.ScreenUpdati开发者_StackOverflowng = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False 

Dim i As Long
For i = 1 To 731055

    'Move two columns in
    ActiveCell.Offset(0, 2).Select

    'Select the customer account and name
    Range(ActiveCell, ActiveCell.Offset(1, 1)).Select

    'Copy and paste it down two rows and over two columns
    Selection.Cut
    ActiveCell.Offset(2, -2).Select
    ActiveSheet.Paste

    'Hop up a couple rows and delete 3 rows before the data that are not useful
    Rows(ActiveCell.Offset(-2).Row).Select
    Selection.Delete Shift:=xlUp
    Selection.Delete Shift:=xlUp
    Selection.Delete Shift:=xlUp

    'Select the next row
    Rows(ActiveCell.Offset(1).Row).Select

    'If the first record in the row is not "USD", then we have multiple rows for
    'this customer
    While (ActiveCell.Offset(0, 2) <> "USD")
        'Copy and Paste the customer account and number for each
        'transaction row
        ActiveCell.Select
        Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 1)).Select
        Selection.Copy
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
        ActiveCell.Select
        ActiveCell.Offset(1, 0).Select
    Wend

    'Delete the two rows after the data that we need
    ActiveCell.Select
    Rows(ActiveCell.Row).Select
    Selection.Delete Shift:=xlUp
    ActiveCell.Select
    Rows(ActiveCell.Row).Select
    Selection.Delete Shift:=xlUp

    'Move to the next row to start over
    ActiveCell.Select
    Debug.Print "Current Row: " & i
Next i

'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub

The problem is that the program is very slow. I let the code run for approximately 10 hours last night, and it only processed 33k. I've got roughly 1.5 mil records to process.

I realize that the technique I am using is actually moving the activecell around, so removing that would likely help. However, I am unsure how to proceed. If this is a lost cause and better suited for a .net implementation, feel free to suggest that.

Your code is jam-packed with Excel-VBA methods that are very inefficient! I'll take a few shots:

Don't use .Select and Selection.. That's super slow.

Why do this

Range(ActiveCell, ActiveCell.Offset(1, 1)).Select
Selection.Cut

when you can do this

Range(ActiveCell, ActiveCell.Offset(1, 1)).Cut

Also don't use ActiveCell to move around your sheet. Just do operations directly on whatever cell or row you need, e.g.

Sheet1.Cells(i,2).Copy
Sheet1.Cells(i,1).Paste

Actually, avoid copy/pasting altogether and just say

Sheet1.Cells(i,1).Value = Sheet1.Cells(i,2).Value

Avoid referring to the same object many times and use With instead. Here, Sheet1 is used twice, so you could write this:

With Sheet1
    .Cells(i,1).Value = .Cells(i,2).Value
End With

The above are just examples that you will have to adjust to your circumstances, and there is more to optimise, but they'll get you started. Show us your code once you've cleaned it up, and more advice will come!

The fast way to do this would be to grab large chunks of data into a 2-D variant array

Dim varr as Variant
varr=Worksheets("Sheet1").Range("C5:G10005")

then loop on the array and create another variant 2-d array (varr2)second that looks the way you want it, then write the variant array to another worksheet:

Worksheets("Sheet2").Range("A2:G2")=varr2

You don't have to select a cell on every command you execute.

Here is a try:

Dim i As Long
'Suppose you want to start on cell A1
With ActiveSheet
    For i = 1 To 731055
        'Move two columns to the right and select the customer account and name
        '.Range("C" & i & ":D" & i + 1).Cut

        'Cut and paste it down two rows and over two columns
        '.Range("A" & i + 2 & ":B" & i + 3).Paste
        .Range("A" & i + 2 & ":B" & i + 3).Value = .Range("C" & i & ":D" & i + 1).Value

        'Hop up a couple rows and delete 3 rows before the data that are not useful
        .Range("A" & i & ":C" & i + 2).EntireRow.Delete

        'If the first record in the row is not "USD", then we have multiple rows for
        'this customer
        While (.Range("C" & i + 1).Value <> "USD")
            'Copy and Paste the customer account and number for each
            'transaction row
            '.Range("A" & i & ":B" & i).Copy
            '.Range("A" & i + 1 & ":B" & i + 1).Paste
            .Range("A" & i + 1 & ":B" & i + 1).Value = .Range("A" & i & ":B" & i).Value
            i = i + 1
        Wend

        'Delete the two rows after the data that we need
        .Range("A" & i + 1 & ":A" & i + 2).EntireRow.Delete

        'Move to the next row to start over
        Debug.Print "Current Row: " & i
    Next i
End With

[edit] i changed a little bit my code to copy only the values (this will be much much faster) instead of copy/paste >> see if you really need to copy paste to keep format or so

[edit] Nick: There were a few numbers that were just a little off, so I've updated the answer to reflect these.

I also posted this on Twitter, and got the following from @VisBasApp:

Sub Process_TransactionsPAT()
Const COL_CUSTOMER_ACC      As Long = 3
Const COL_CUSTOMER_NAME     As Long = 4
Const COL_CUSTOMER_VOUCHER  As Long = 4
Const COL_CUSTOMER_INVOICE  As Long = 5
Const COL_CUSTOMER_TRANS    As Long = 6
Const COL_CUSTOMER_CURR     As Long = 7
Const COL_CUSTOMER_AMT_CUR  As Long = 8
Const COL_CUSTOMER_BAL_CUR  As Long = 9
Const COL_CUSTOMER_BAL      As Long = 10
Const COL_CUSTOMER_DUE_DATE As Long = 11
Const COL_CUSTOMER_COL_CODE As Long = 12

Const TEXT_TO_CHECK         As String = "Customer account"

Dim accNumber           As Variant
Dim accName             As String
Dim index               As Long
Dim counter             As Long
Dim originalData        As Variant
Dim transferedData()    As Variant

'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False

originalData = Range("A1:L720909")

counter = 0
For i = 1 To UBound(originalData, 1)
    If originalData(i, COL_CUSTOMER_ACC) = TEXT_TO_CHECK Then

        ' go to the first row under the text 'Customer Account'
        index = i + 1

        ' get name and account number
        accNumber = originalData(index, COL_CUSTOMER_ACC)
        accName = originalData(index, COL_CUSTOMER_NAME)

        ' go to the first row under the text 'Date'
        index = index + 2
        counter = counter + 1
        While (UCase(originalData(index, COL_CUSTOMER_ACC)) <> "USD")

            ReDim Preserve transferedData(1 To 12, 1 To counter)
            transferedData(1, counter) = accNumber
            transferedData(2, counter) = accName
            transferedData(3, counter) = originalData(index, COL_CUSTOMER_ACC)
            transferedData(4, counter) = originalData(index, COL_CUSTOMER_VOUCHER)
            transferedData(5, counter) = originalData(index, COL_CUSTOMER_INVOICE)
            transferedData(6, counter) = originalData(index, COL_CUSTOMER_TRANS)
            transferedData(7, counter) = originalData(index, COL_CUSTOMER_CURR)
            transferedData(8, counter) = originalData(index, COL_CUSTOMER_AMT_CUR)
            transferedData(9, counter) = originalData(index, COL_CUSTOMER_BAL_CUR)
            transferedData(10, counter) = originalData(index, COL_CUSTOMER_BAL)
            transferedData(11, counter) = originalData(index, COL_CUSTOMER_DUE_DATE)
            transferedData(12, counter) = originalData(index, COL_CUSTOMER_COL_CODE)
            index = index + 1
            counter = counter + 1
        Wend

        ' it is not the best technique but for now it works
        i = index + 1
        counter = counter - 1
    End If
Next i

' add data on a new sheet
Sheets.Add
Cells(1, 1) = "Customer Account"
Cells(1, 2) = "Name"
Cells(1, 3) = "Date"
Cells(1, 4) = "Voucher"
Cells(1, 5) = "Invoice"
Cells(1, 6) = "Transaction Left"
Cells(1, 7) = "Currency"
Cells(1, 8) = "Amount in currency"
Cells(1, 9) = "Balance in currency"
Cells(1, 10) = "Balance"
Cells(1, 11) = "Due Date"
Cells(1, 12) = "Collection letter code"
For i = 1 To UBound(transferedData, 2)
    For j = 1 To UBound(transferedData, 1)
        Cells(i + 1, j) = transferedData(j, i)
    Next j
Next i

Columns.AutoFit
'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True

End Sub

This takes roughly 2 minutes to parse 750,000 records.

I would throw the data as-is on a database, and write a query to do that. I'll write a query and update the answer when I get home (I'm on my phone, its impossible to write SQL :)