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.

 

[GJSBED]

I think you are looking for an Excel Solution, when Access is the weapon to be using here.

Write queries in the Access database that will return a result for each region and then export them / import them to excel.

 

[gallen]

I think this line should read False:

Application.ScreenUpdating = True

just make sure to set it back to true at the end of the code.

Also use

Application.EnableEvents = False

Again making sure to set back to True at the end

 

[steve the fish]

This should be very fast. However im not entirely clear on the make up of your sheet so test on a copy of your workbook first!!!

Dim lr As Long, lrky As Long, rngMyRange As Range, d As Object, c As Range, ky, tmp As String
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
With Worksheets("Bid Sheet Query")
    'find last row
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    'set range to work on
    Set rngMyRange = .Range("A2:A" & lr)
    'get unique values in range
    Set d = CreateObject("scripting.dictionary")
    For Each c In rngMyRange
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c
    'autofilter
    For Each ky In d.keys
        If .AutoFilterMode Then .AutoFilterMode = False
        With rngMyRange.Offset(-1, 0).Resize(lr)
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=ky
            If .SpecialCells(xlCellTypeVisible).Count > 1 Then
                .Offset(1, 0).Resize(lr - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                With Sheets(ky)
                    lrky = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & lrky).PasteSpecial xlPasteValues
                End With
            End If
        End With
        .AutoFilterMode = False
    Next
End With
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .CutCopyMode = False
End With

Edit. One caveat. You need a header in cell A1 of sheet 'Bid Sheet Query'. Autofilter likes headers.

 

[Mierin]

Thanks for the feedback. I am happy to try separating the access query by region, but I am not sure how that helps my Rows to Columns issue. It seems that I will then just have to do the copy / paste / transpose from ~40 different queries onto ~40 different tabs. Is there a way to make Access queries transpose themselves before I import?

I think you are looking for an Excel Solution, when Access is the weapon to be using here.

Write queries in the Access database that will return a result for each region and then export them / import them to excel.

 

[Mierin]

Thanks, gallen. I turned on screen updating so I could see where it was working slowly. It sadly runs at about the same speed whether it is True or False. Events are turned off and on in different modules which are chained together in this process, but thank you for mentioning in case I hadn't thought of it.

I think this line should read False:

Application.ScreenUpdating = True

just make sure to set it back to true at the end of the code.

Also use

Application.EnableEvents = False

Again making sure to set back to True at the end

 

[svendiamond]

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

 

[Mierin]

Hi Steve,

Thanks. It is extremely fast and worked with no adjustments. Nice work there. I am totally jealous. However, this doesn't actually do what I need it to do. This just moves rows from the query tab to rows on regional tabs. I need to transpose the rows to columns when I move them to the regional tabs. As mentioned, that seems to be the part that is slowing the process down.

This should be very fast. However im not entirely clear on the make up of your sheet so test on a copy of your workbook first!!!

Dim lr As Long, lrky As Long, rngMyRange As Range, d As Object, c As Range, ky, tmp As String
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
With Worksheets("Bid Sheet Query")
    'find last row
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    'set range to work on
    Set rngMyRange = .Range("A2:A" & lr)
    'get unique values in range
    Set d = CreateObject("scripting.dictionary")
    For Each c In rngMyRange
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c
    'autofilter
    For Each ky In d.keys
        If .AutoFilterMode Then .AutoFilterMode = False
        With rngMyRange.Offset(-1, 0).Resize(lr)
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=ky
            If .SpecialCells(xlCellTypeVisible).Count > 1 Then
                .Offset(1, 0).Resize(lr - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                With Sheets(ky)
                    lrky = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & lrky).PasteSpecial xlPasteValues
                End With
            End If
        End With
        .AutoFilterMode = False
    Next
End With
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .CutCopyMode = False
End With

Edit. One caveat. You need a header in cell A1 of sheet 'Bid Sheet Query'. Autofilter likes headers.

 

[Mierin]

Thanks, svendiamond! I am happy to try that, but I don't understand how I apply that concept to my code. How do I transpose without pasting? It would seem that the ranges are not congruent and therefore cannot be Value set. Am I misunderstanding something?

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

 

[svendiamond]

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?