0

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
Improve this question
10
  • Research value transfer... instead of using copy/pastevalues. Commented Mar 16, 2020 at 16:31
  • Why are you copying rows in a loop though? Commented Mar 16, 2020 at 16:32
  • Because its all I know! Commented Mar 16, 2020 at 16:33
  • 3
    @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. Commented Mar 16, 2020 at 16:53
  • 1
    @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. Commented Mar 16, 2020 at 16:58

4 Answers 4

Reset to default
1

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
Improve this answer
Sign up to request clarification or add additional context in comments.

Comments

0

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.

Improve this answer

Comments

0

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
Improve this answer

Comments

0

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
Improve this answer

16 Comments

That could work too. I wouldn't have thought to use the .Resize method.
Hi @FaneDuru, yes the Front Team, Mid Team & Rear Team need to be added to each row. Other than that this is much faster. Also it does not add the original worksheet name into column J, it just adds the destination worksheet name (Export_Sheet) to J1, which is not the intention.
OK. Let us clarify some things: The workbook name is returned exactly as it was in your code... In the last empty cell of the column J:J. If you do not have any value in this column, it will be returned in its first cell. If you need something else, for instance, to be returned on the last line of the pasted range, it can be done, but you must say that. I do not know what is your need. About the other three 'something Team', should they be inserted between each row and practically there will be three rows, each of it keeping only such a value in column K:K? If yes, may I ask you Why?
I mean it is more complicated (keeping the code fast) and I do not want loosing time if I do not understand that this is a must... Do you need the sheet name on each row?
Do you want that the J cell copied value of each row to be replaced by sheet name? This your code used to do...
|

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.