Extremely Slow Copy / Paste VBA - How Do I Speed This Up?

[Mierin]

Hello All,

Long time reader, first time poster. Thanks to the entire community for helping me learn every day.

I have a workbook that queries an access database and then copy / paste / transposes each row to a column on a region specific tab to re-create a sheet that is used by the entire sales team. Unfortunately, when testing the code below, it took almost an hour to move <400 test records. Before I added the Save after each row, it would bomb out 50 records in because it ran out of memory. Any assistance on how to clean up my cobbled together solution to this problem is most appreciated. If I am going about this the wrong way, I am open to changing approaches. I just need the rows of data from the db to end up in columns on the spreadsheet. Where, when, and how that happens is flexible. I am a contractor hoping to get hired full-time and this working smoothly will go a long way toward impressing the management.

Sub CopyRows()
Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastColumn As Long
Dim SheetName As String
Dim SaveColNdx
Application.ScreenUpdating = True
With Worksheets("Bid Sheet Query")
Set rngMyRange = .Range(.Range("a2"), .Range("A65536").End(xlUp))
    For Each rngCell In rngMyRange
        rngCell.EntireRow.Select
        Selection.Copy
            SheetName = rngCell.Value
            Sheets(SheetName).Select
            Set sht = ThisWorkbook.Worksheets(SheetName)
            Range("A1:PP1").Select
            Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
            SaveColNdx = ActiveCell.Column
            Columns(SaveColNdx).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
               False, Transpose:=True

        Sheets("Bid Sheet Query").Select
        ActiveWorkbook.Save
    Next
End With
End Sub

Thanks again for any help anyone can provide for me.

 

[Mierin]

Yes. That is it exactly, sven! My code does it, but it is obnoxiously slow. I would love to have a better method even if it means re-writing the whole thing. I just don't know what that other method would be. I welcome any ideas.

Oh I see. Ok, so, you basically want to take each row in your data from sheet "Bid Sheet Query" and transpose it into the next available column on the sheet with the corresponding name from column A? Is this correct?

 

[svendiamond]

Ok try this code, just adjust the sheet names for the ws1 and ws2 variables. ws1 is your original data. Make a new blank sheet (I called mine "transposed") and this code will transpose everything all at once, then go column by column and copy the data into the next available column in the corresponding sheet name. Let me know how it goes.

Sub copyRowsNew()


Dim lastRow As Long, lastCol As Long, nextCol As Long, c As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet


Set ws1 = Sheets("original")
Set ws2 = Sheets("transposed")
    ws2.Cells.ClearContents


With ws1
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
    .Range("A1:I" & lastRow).Copy
    ws2.Range("A1").PasteSpecial Transpose:=True
End With
   
For c = 1 To lastRow
   
    On Error Resume Next
    Set ws3 = Sheets(ws2.Cells(1, c).Value)
    If ws3 Is Nothing Then
        MsgBox "Couldn't find a sheet named """ & ws2.Cells(1, c).Value & """"
    Else
        With ws3
            .Activate
            nextCol = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
            ws2.Columns(c).Copy .Columns(nextCol)
        End With
        Set ws3 = Nothing
    End If
Next c


Application.CutCopyMode = False
End Sub

 

[Mierin]

BRILLIANT! Transpose them all at once and then move them. I totally should have thought of that. *FACEPALM* This is so fast and required only a couple of little tweaks to fit my project. Thank you so much for helping me out with this. I cannot tell you how much it means to me.

Ok try this code, just adjust the sheet names for the ws1 and ws2 variables. ws1 is your original data. Make a new blank sheet (I called mine "transposed") and this code will transpose everything all at once, then go column by column and copy the data into the next available column in the corresponding sheet name. Let me know how it goes.

Sub copyRowsNew()


Dim lastRow As Long, lastCol As Long, nextCol As Long, c As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet


Set ws1 = Sheets("original")
Set ws2 = Sheets("transposed")
    ws2.Cells.ClearContents


With ws1
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
    .Range("A1:I" & lastRow).Copy
    ws2.Range("A1").PasteSpecial Transpose:=True
End With
    
For c = 1 To lastRow
    
    On Error Resume Next
    Set ws3 = Sheets(ws2.Cells(1, c).Value)
    If ws3 Is Nothing Then
        MsgBox "Couldn't find a sheet named """ & ws2.Cells(1, c).Value & """"
    Else
        With ws3
            .Activate
            nextCol = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
            ws2.Columns(c).Copy .Columns(nextCol)
        End With
        Set ws3 = Nothing
    End If
Next c


Application.CutCopyMode = False
End Sub

 

[spell]

In general, copying and pasting can be slow. Instead, set the value of the cells to equal each other. For example:

'instead of this:
Sheet1.Range("A1:Z10000").Copy Sheet2.Range("A1")

'try this:
Sheet2.Range("A1:Z10000").Value = Sheet1.Range("A1:Z10000").Value

Hey svendiamond

I was having a headache with my painfully slow nested copy/paste loop for ws1 -> ws_autogenerated#1, ws1 -> ws_autogenerated#2 etc. It worked, but it took about ~30 seconds for a simple table (A1:S15) to finish.
Changing the solution of copying/pasting, to equal the cells to each other changed the load time from ~30 seconds to instant reaction. This was exactly, spot on, 100% what I was looking for.

Going from this:
...
Worksheets(ws1).Range().Offset().Copy 'Copy offset from Timetable
Worksheets(ws_autogenerated).Range().Offset().PasteSpecial Paste:=xlPasteValues 'Paste offset to new generated sheet without cell formatting
...

To this:
...
Worksheets(ws_autogenerated).Range().Offset() = Worksheets(ws1).Range().Offset().Value
...

With this simple tweak, I also don't have to worry about the cell paste format (cell border, color, size etc.) when I only want the cell content.

Thanks!

 

[svendiamond]

Hey svendiamond

I was having a headache with my painfully slow nested copy/paste loop for ws1 -> ws_autogenerated#1, ws1 -> ws_autogenerated#2 etc. It worked, but it took about ~30 seconds for a simple table (A1:S15) to finish.
Changing the solution of copying/pasting, to equal the cells to each other changed the load time from ~30 seconds to instant reaction. This was exactly, spot on, 100% what I was looking for.

Going from this:
...
Worksheets(ws1).Range().Offset().Copy 'Copy offset from Timetable
Worksheets(ws_autogenerated).Range().Offset().PasteSpecial Paste:=xlPasteValues 'Paste offset to new generated sheet without cell formatting
...

To this:
...
Worksheets(ws_autogenerated).Range().Offset() = Worksheets(ws1).Range().Offset().Value
...

With this simple tweak, I also don't have to worry about the cell paste format (cell border, color, size etc.) when I only want the cell content.

Thanks!

Nice!!! I'm so glad it was helpful to you. This is a great forum.