Copy and paste VBA code- looking to improve it.

[Giovanni03]

Hello Guys!

I have a code that works great for what I'm looking to do however there is just one portion of the code that I'm wondering if what I'm trying to achieve could be implemented. Basically what the code does is that it allows me to select any number of rows then when I run the macro, it paste those rows into the sheet I need it in and then deletes it from the sheet that it was copied from. Again it works great but when the copied data gets pasted onto the new sheet it paste over a section that I would like to keep (basically a notes section that I include on the the pasted sheet that starts in column L)

Is is possible to have only columns A-K paste and not the entire row which has a ton of blanks after column k.

Sub CopyToSIS()
    
    'Declarations.
    Dim RngSource As Range
    Dim RngDestination As Range
    Dim RngArea As Range
    Dim RngCell As Range
    Dim RngChop As Range
    Dim DblBottomRow As Double
    Dim DblTopRow As Double
    Dim DblRow As Double
    
    'Settings.
    Set RngSource = Selection
    Set RngDestination = Sheets("S.I.S").Range("A1").End(xlDown)
    
    
    'Checking if RngDestination is empty, which means its not the last cell of the list.
    If Excel.WorksheetFunction.CountBlank(RngDestination) = RngDestination.Cells.Count Then
        
        'Setting RngDestination.
        Set RngDestination = RngDestination.End(xlUp).Offset(1, 0)
    
    Else
        
        'Setting RngDestination.
        Set RngDestination = RngDestination.Offset(1, 0)
        
    End If
    
    'Covering each area of RngSource.
    For Each RngArea In RngSource.Areas
        
        'Covering each cell of RngArea.
        For Each RngCell In RngArea.Cells
            
            'Checking if RngChop is nothing.
            If RngChop Is Nothing Then
                
                'Setting RngChop.
                Set RngChop = RngCell.EntireRow
                
            Else
                
                'Setting RngChop.
                Set RngChop = Union(RngChop, RngCell.EntireRow)
                
            End If
            
        Next
        
    Next
    
    'Covering each row of RngChop.
    For Each RngArea In RngChop.Rows
        
        'Copying the row.
        RngArea.copy RngDestination
        
        'Setting RngDestination for the next row.
        Set RngDestination = RngDestination.Offset(1, 0)
        
    Next
    
    'Deleting RngChop.
    RngChop.Delete
    


End Sub

 

[dsehguht]

this isnt a direct answer but something similar i have done in the past.

i find that this array system is faster processing than copy and paste.

y1 and y2 are my first and last rows of the data i want to move. the columns are fixed values.

y1 As Integer, y2 As Intege
Dim Pg As Worksheet
Dim LastPC As Range, FirstPC As Range
Dim Array_PCN As Variant

'gathering array.
Array_PCN = ActiveWorkbook.Sheets("Cleaned").Range("A" & y1 & ":Y" & y2).Value      'store data

'pasting array
Pg.Range("A3:Y" & y2 - FirstPC.Row + 3) = Array_PCN          'paste, array sizes will give bad or weird results if they dont match

 

[Giovanni03]

I tried it but couldn't get it to work. not sure if its something I link to a macro button

 

[Akuini]

it allows me to select any number of rows

Is it possible that you select non-contiguous rows?

 

[Akuini]

Maybe this:

    'Covering each row of RngChop.
    For Each RngArea In RngChop.Rows
        
        'Copying the row.
        RngArea.Resize(, 11).Copy RngDestination  'resize to cover col A:K only
        
        'Setting RngDestination for the next row.
        Set RngDestination = RngDestination.Offset(1, 0)
        
    Next

 

[Giovanni03]

Maybe this:

    'Covering each row of RngChop.
    For Each RngArea In RngChop.Rows
       
        'Copying the row.
        RngArea.Resize(, 11).Copy RngDestination  'resize to cover col A:K only
       
        'Setting RngDestination for the next row.
        Set RngDestination = RngDestination.Offset(1, 0)
       
    Next

Thank you!!!! this worked! I could figure out how to type out the range, good to now that its not range "A:K" but ,11.

 

[Akuini]

Thank you!!!! this worked! I could figure out how to type out the range, good to now that its not range "A:K" but ,11.

You're welcome, glad to help & thanks for the feedback.

 

[Akuini]

Pg.Range("A3:Y" & y2 - FirstPC.Row + 3) = Array_PCN 'paste, array sizes will give bad or weird results if they dont match

@dsehguht
to make sure the range & the array have the same size, you can use Resize (assuming the lower bound is 1):

Pg.Range("A3").Resize(UBound(Array_PCN, 1), UBound(Array_PCN, 2)) = Array_PCN