Excel VBA Copy Paste Data Too Slow

0
votes

I have the following code that grabs data from many worksheets in my workbook and dumps it into a new worksheet named "Export_Sheet".

Since the code relies on Copy\Paste method it takes forever and I am looking to replace this with something much faster.

Any clues? I'm not looking for a resolution for this, more just a steer in the right direction, as I don't know of any faster processes myself, but am sure they exist.

Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(1)).Name = "Export_Sheet"

Dim Ws As Worksheet

For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And Ws.Name <> "Mid Team Project List" And Ws.Name <> "Rear Team Project List" And Ws.Name <> "Acronyms" Then

LastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row

For i = 6 To LastRow

Ws.Cells(i, 9).EntireRow.Copy
Sheets("Export_Sheet").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValues
Sheets("Export_Sheet").Range("j" & Rows.Count).End(xlUp).Value = Ws.Name

If Ws.Range("J1").Value = "Front Team" Then
Sheets("Export_Sheet").Range("k" & Rows.Count).End(xlUp).Offset(1).Value = "Front Team"
End If

If Ws.Range("J1").Value = "Mid Team" Then
Sheets("Export_Sheet").Range("k" & Rows.Count).End(xlUp).Offset(1).Value = "Mid Team"
End If

If Ws.Range("J1").Value = "Rear Team" Then
Sheets("Export_Sheet").Range("k" & Rows.Count).End(xlUp).Offset(1).Value = "Rear Team"
End If

Next i

End If
Next
End Sub
4
excelvbacopypaste
Research value transfer... instead of using copy/pastevalues. – BigBen
Why are you copying rows in a loop though? – BigBen
Because its all I know! – Faminebob
@Nemoko Excel (and each of the Office applications), get VBA from a DLL. In the VB Editor you can see it listed as the first item in Tools --> References. Communication between the host application (Excel in our case) and the DLL (and vice versa) is orders of magnitudes slower than communication withing either. So, it is smart to limit the number of communications between the two. One of the slowest things is repeated access cells in a loop from VBA because this requires two-way communication for every single cell. It is only one communication to assign a large range to a VBA array. – Excel Hero
@Nemoko Both processes are very fast on their own. The communication between them is slow. There is a bunch of setup and tear down work for every single communication between the two. This support work is so substantial that it is literally just as quick to bring across the values of 10,000 cells into a VBA array (in one array assignment, i.e v = Range("A1:A999").Value) as it is to bring 1 value into a scalar variable. The same holds true for writing data to a worksheet from VBA. – Excel Hero

4 Answers

1
votes

Ok Here's my stab for direct transfer instead of using the clipboard. There may be better ways.

The UsedRange property of a worksheet is everything from Range("A1") to whereever Ctrl+End takes you. It might be blank cells way down there, but it's where Excel thinks the end of the "used range" is. This is needed to restrict the range of .EntireRow or it might stretch out across the entire sheet to column #16,384, the max for the column count.

My understand of what you're trying to copy is a bit shaky, but that loop in the middle is what does it. First it uses Intersect() to cross the .UsedRange with row you want to work in. Then it counts through the source and destination ranges one cell at a time, and copies the value from one to the other.

Private Sub CommandButton3_Click()
    Application.ScreenUpdating = False
    Worksheets.Add(After:=Worksheets(1)).Name = "Export_Sheet"

    Dim Ws      As Worksheet
    Dim ur      As Excel.range
    Dim srcCell As Excel.range
    Dim srcRng  As Excel.range
    Dim srcCnt  As Long
    Dim xferCnt As Long
    Dim topCell As Excel.range

    For Each Ws In ThisWorkbook.Worksheets
        Set ur = Ws.UsedRange 'This is usually A1 to where Ctrl+End sends you.
        If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And Ws.Name <> "Mid Team Project List" And Ws.Name <> "Rear Team Project List" And Ws.Name <> "Acronyms" Then
            LastRow = Ws.Cells(rows.Count, 1).End(xlUp).row
            For i = 6 To LastRow
                Set srcRng = Intersect(ur, Ws.Cells(i, 9).EntireRow)    'Only get the used part of the row.
                srcCnt = dataRng.Cells.Count                            'Count of cells in source.
                For xferCnt = 0 To srcCnt - 1
                    'Now you basically need something like this,
                    'Get the top cell as a reference point.
                    Set topCell = Sheets("Export_Sheet").range("A" & rows.Count).End(xlUp).Offset(1)
                    'Then transfer each cell one at a time.
                    topCell.Offset(0, xferCnt).Value = srcRng.Cells(xferCnt).Value
                    Sheets("Export_Sheet").range("j" & rows.Count).End(xlUp).Value = Ws.Name
                Next
                If Ws.range("J1").Value = "Front Team" Then
                    Sheets("Export_Sheet").range("k" & rows.Count).End(xlUp).Offset(1).Value = "Front Team"
                End If
                If Ws.range("J1").Value = "Mid Team" Then
                    Sheets("Export_Sheet").range("k" & rows.Count).End(xlUp).Offset(1).Value = "Mid Team"
                End If
                If Ws.range("J1").Value = "Rear Team" Then
                    Sheets("Export_Sheet").range("k" & rows.Count).End(xlUp).Offset(1).Value = "Rear Team"
                End If
            Next i
        End If
    Next
End Sub
0
votes

This does not address your specific code; it just demos an alternative approach.

This kind of code:

Sub CopyPaste()
    Sheets("Sheet1").Range("A1:Z100").Copy
    Sheets("Sheet2").Range("A1").PasteSpecial (xlPasteValues)
End Sub

may seem quite fast unless it is performed in large loops. If all you have is data (no formulas), then:

Sub Value2Value()
    Sheets("Sheet2").Range("A1:Z100").Value = Sheets("Sheet1").Range("A1:Z100").Value
End Sub

is faster. If there are formulas in the block then:

Sub Form2Form()
    Sheets("Sheet2").Range("A1:Z100").Formula = Sheets("Sheet1").Range("A1:Z100").Formula
End Sub

will copy both formulas and data.

The disadvantage of the quick copies is that formatting may not be copied along with the values.

0
votes

Untested since I don't have your workbook, but this should be orders of magnitude faster...

Private Sub CommandButton3_Click()
    Dim Ws As Worksheet
    Application.ScreenUpdating = False
    Worksheets.Add(After:=Worksheets(1)).Name = "Export_Sheet"

    For Each Ws In ThisWorkbook.Worksheets
        With Ws
            If .Name <> "Contents Page" And .Name <> "Completed" And .Name <> "VBA_Data" And .Name <> "Front Team Project List" And .Name <> "Mid Team Project List" And .Name <> "Rear Team Project List" And .Name <> "Acronyms" Then
                For i = 6 To .Cells(Rows.Count, 1).End(xlUp).Row
                    With Sheets("Export_Sheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
                        .Value = Ws.Cells(i, 9).EntireRow.Value
                        .Offset(, 9).Value = Ws.Name
                        Select Case Ws.Range("J1").Value
                            Case "Front Team", "Mid Team", "Rear Team": .Offset(, 9).Value = Ws.Range("J1").Value
                        End Select
                    End With
                Next
            End If
        End With
    Next
End Sub
0
votes

Try this code, please.

Private Sub CommandButton3_Click()
 Dim Ws As Worksheet, lastRow As Long, lastCol As Long
 Dim shExp As Worksheet, arrTransf As Variant

  Set shExp = Worksheets.Add(After:=Worksheets(1))
  shExp.Name = "Export_Sheet"

 For Each Ws In ThisWorkbook.Worksheets
  If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And _
            Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And _
            Ws.Name <> "Mid Team Project List" And Ws.Name <> _
                      "Rear Team Project List" And Ws.Name <> "Acronyms" Then
    lastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row

        lastCol = ws.UsedRange.Columns.Count
        arrTransf = ws.Range(ws.Cells(6, 1), ws.Cells(lastRow, lastCol)).Value
        lastRExp = shExp.Range("A" & Rows.Count).End(xlUp).row + 1
        shExp.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arrTransf, 1), _
                                         UBound(arrTransf, 2)).Value = arrTransf

        shExp.Range("j" & Rows.Count).End(xlUp).Value = ws.Name 'here, it is necessary to confirm that this is what you want (it depends on the number of columns in your file, which I do not know)...

        Select Case ws.Range("J1").Value
            Case "Front Team", "Mid Team", "Rear Team"
                shExp.Range("K" & lastRExp).Resize(UBound(arrTransf, 1)).Value = ws.Range("J1").Value
        End Select
  End If
 Next
End Sub

Edited: The second code which deal with inserting of another row after each one keeping data. Please, test it and confirm that this is what you wanted. Especially, regarding the sheet name position...

Private Sub CommandButton3_Click()
 Dim Ws As Worksheet, lastRow As Long, lastCol As Long, k As Long, i As Long
 Dim shExp As Worksheet, arrTransf As Variant, arrFin As Variant, m As Long

  Set shExp = Worksheets.Add(After:=Worksheets(1))
  shExp.Name = "Export_Sheet"

 For Each Ws In ThisWorkbook.Worksheets
      If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And _
            Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And _
            Ws.Name <> "Mid Team Project List" And Ws.Name <> _
                      "Rear Team Project List" And Ws.Name <> "Acronyms" Then

        lastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row

        lastCol = Ws.UsedRange.Columns.Count
        arrTransf = Ws.Range(Ws.Cells(6, 1), Ws.Cells(lastRow, lastCol)).value

        ReDim arrFin(1 To UBound(arrTransf, 2), 1 To UBound(arrTransf, 1) * 4)
        For i = 1 To UBound(arrTransf, 1)
            For m = 1 To UBound(arrTransf, 2)
                arrFin(m, i + IIf(m > 11, k - 1, k)) = arrTransf(i, m)
                If m = 10 Then arrFin(10, i + k) = Ws.Name
                'If you would need the sheet name on the same row with "xxx Team, replace the above line with the next one. In fact uncomment it and delete the above one:
                'If m = 10 Then arrFin(10, i + k + 1) = Ws.Name
                If m = 11 Then
                    If Ws.Range("J1").value = "Front Team" Then
                        arrFin(11, i + k + 1) = "Front Team": k = k + 1
                    ElseIf Ws.Range("J1").value = "Mid Team" Then
                        arrFin(11, i + k + 1) = "Mid Team": k = k + 1
                    ElseIf Ws.Range("J1").value = "Rear Team" Then
                        arrFin(11, i + k + 1) = "Rear Team": k = k + 1
                    End If
                End If
            Next m
        Next i
        ReDim Preserve arrFin(1 To UBound(arrTransf, 2), i + k - 2)
        shExp.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arrFin, 2), _
                        UBound(arrFin, 1)).value = WorksheetFunction.Transpose(arrFin)
     End If
 Next
End Sub