Shorter way to copy/paste between sheets

twvanduzee · Jun 2nd 2021

Hello

I have a sheet with approximately 1200 rows of data.

Currently, the only way for me to copy rows to different sheets is to select each row (based on specific criteria (column value)).

It all works, but it takes a while to run - because I am iterating through each of the 1200 rows, finding a value from the O column, finding the appropriate sheet to paste it into, and then pasting the entire row of data into the next available row.

So, what Im doing is looking through each cell in the O column, grabbing the value, and comparing it to the sheet names (the sheetnames were created based on the unique values from the O column). When it finds the sheet name with the same value as the cell, it pastes the row into the next available row.

But it does this for 28 different sheets (potentially). so it takes approx 30,000 searches/copies/pastes.

Ex:

the O column contains 50 occurances of "Community Services", 65 occurences of "Corporate Services" etc for 1200 rows of data.

I have sheets by those two names (Community Services and Corporate Services).

Is there a way to have vba scan through all 1200 rows and select/copy all the appropriate rows, then do 1 paste into the appropriate sheet?

Thank You

Terry

jolivanes · Jun 2nd 2021

Code

Sub Maybe()
Dim sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Master" Then
If WorksheetFunction.CountIf(Columns(15), sh.Name) <> 0 Then
With Sheets("Master").Cells(1).CurrentRegion
.AutoFilter 15, sh.Name
.Offset(1).SpecialCells(12).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
End If
End If
Next sh
Sheets("Master").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
This goes through all sheets except the Master. I might have misunderstood that you only want to transfer 2 sheet names.
If so, let us know

Display More

jolivanes · Jun 2nd 2021

I neglected to mention that the sheet with the data is named "Master".

Change that in the code to the actual sheet name

My apologies for that

Justin Doward · Jun 3rd 2021

Alternatively you could try a loop like:

Code

Sub copyRWs()
Application.ScreenUpdating = False
Dim a
a = Application.Transpose(Sheet1.Range("O2:O" & Sheet1.Cells(Rows.Count, "O").End(xlUp).Row)) 'creates array from O2:last row
For i = LBound(a) To UBound(a)
Sheet1.Rows(i + 1).EntireRow.copy (Sheets(a(i)).Cells(Sheets(a(i)).Cells(Rows.Count, 14).End(xlUp).Row + 1, 1)) 'copies each row
Next i
Application.ScreenUpdating = True
End Sub

This assumes you have a table starting on row 1, change sheet1 to your sheetname , if jolivanes nor my response achieve what you are after an example worksheet is probably needed.

vcoolio · Jun 3rd 2021

Hello Terry,

We could take both suggestions from Jolivanes and Justin one step further.

To speed things up a little more, extracting the unique names first from Column O, placing them in a temporary helper column, sorting them Ascending then placing them into an array will reduce iterations considerably. The code I have in mind is as follows:-

Code

Option Explicit

Sub TerryTest()

              Dim i As Integer, lr As Long
              Dim sh As Worksheet, wsD As Worksheet, ar As Variant
        
Application.ScreenUpdating = False
        
              Set sh = Sheets("Master")
              lr = sh.Range("A" & Rows.Count).End(xlUp).Row
              sh.Range("O1:O" & lr).AdvancedFilter 2, , sh.[Z1], 1  'Unique values moved temporarily to Column Z.
              sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp)).Sort [Z2], 1 'Unique values sorted.
              ar = sh.Range("Z2", sh.Range("Z" & sh.Rows.Count).End(xlUp))
              
       For i = 1 To UBound(ar)
                    
              Set wsD = Sheets(CStr(ar(i, 1))) '---->Destination worksheets.
              wsD.UsedRange.Clear
                    
              With sh.[A1].CurrentRegion
                   .AutoFilter 15, ar(i, 1)
                   .Copy wsD.[A1]
                   .AutoFilter
             End With
                   wsD.Columns.AutoFit
       Next i

             sh.Columns("Z").Clear 'Clear helper column to be used again as needed.
             sh.Select

Application.ScreenUpdating = True

End Sub

Display More

I've randomly selected Column Z as the helper column. You can use any column you wish well away from your data set.

You will be able to add further worksheets as required. The code will take care of the rest.

I've attached a sample workbook to show you how this works. Click on the "TEST" button.

I hope that this helps.

Cheerio,

vcoolio.

Terry Test.xlsm

**royUK** · Jun 3rd 2021

This is untested.

Code

Sub CopyData()
    Dim oWs As Worksheet
    Dim rRng As Range
    For Each oWs In ThisWorkbook.Worksheets
        If oWs.Name <> "Data" Then ''/// Data is assumed name of sheet containing data
            With Sheets("Data") ''///name of sheet containing data
                If Not .AutoFilterMode Then .Range("A1").AutoFilter
                .Range("A1").AutoFilter Field:=15, Criteria1:=oWs.Name
                 Set rRng = .AutoFilter.Range
                rRng.Offset(1, 0).Resize(rRng.Rows.Count - 1, _
                rRng.Columns.Count).Copy oWs.Cells(oWs.Rows.Count, 1).End(xlUp).Offset(1)
            End With
        End If
    Next oWs
    Sheets("Data").Range("A1").AutoFilter
End Sub

Display More

Shorter way to copy/paste between sheets

Participate now!

Share

Users Viewing This Thread