Script to Copy and paste entirerows and mergedrows?

Question

The following code is the one that I'm trying to work with, but I still can't make it work with merge rows. The main idea is to create a loop to check each row from D1:D150 and if the criteria are met then copy the entire row.

This is how my data looks like

Sub attributes()
    '--------------------------------------------------------------------
    Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
    Dim strAsses1 As Boolean
    Dim num As Integer
    '------------------------------
    Set ws = ActiveWorkbook.Sheets("Contract Attributes")
    Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
    ws.Activate
    Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
    'Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("D1:D150")
    'Set aCell2 = ActiveWorkbook.Sheets("Contract Attributes").Range("D:D").Find("Current Modifications", LookIn:=xlValues)
    '--------------------------------------------------------------------
    strName1 = InputBox("Which contract modification would you like to review?")
    num = 5
    For Each Cel In aCell1
        If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
            Cel.MergeArea.Select
            Selection.EntireRow.Copy
    
            ws0.Activate
            Rows(num).Insert
            ws.Activate
            num = num + 1
        End If
    Next Cel
    '--------------------------------------------------------------------
    'ws0.Columns(4).Delete
    'aCell2.Select
    'ActiveCell.EntireRow.Copy
    'Sheets("ReviewerTab").Range("A5").Insert
End Sub

score 1 · Answer 1 · answered Sep 29 '20 at 06:26

TIPS

To begin with, I would recommend that you see How to avoid using Select in Excel VBA. Next you need to identify the range object that you need to copy and then copy them across.
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range You need to declare them explicitly else the first four objects are declared as Variant and not Range. For example Dim Cel As Range, aCell1 As Range, aCell2 As Range, aCell3 As Range, aCellAsses As Range
Do not copy the rows in a loop. It will be slow. Identify the rows you want to copy and then copy them in one go. Below is an example

SAMPLE SCENARIO

To demonstrate how this works, I am taking the below sample.

CODE

I have come up with a basic code. I have commented it so you should not have a problem understanding it. But if you do then feel free to ask :).

Option Explicit

Sub Sample()
    Dim wsInput As Worksheet
    Dim wsOuput As Worksheet
    Dim RangeToCopy As Range
    Dim lRow As Long, i As Long, num As Long
    Dim searchText As Variant
    
    '~~> Row in output sheet where the rows will be copied
    num = 5
    
    '~~> Set your input and output sheets
    Set wsInput = ThisWorkbook.Sheets("Contract Attributes")
    Set wsOuput = ThisWorkbook.Sheets("ReviewerTab")
    
    '~~> Take the input from the user
    searchText = InputBox("Which contract modification would you like to review?")
    
    If Len(Trim(searchText)) = 0 Then Exit Sub
    
    With wsInput
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Loop through the cells and check for criteria
        For i = 1 To lRow
            If InStr(1, .Range("A" & i).Value2, searchText, vbTextCompare) Then
                '~~> identify the rows you need to copy and store them
                '~~> in a range object
                If RangeToCopy Is Nothing Then
                    Set RangeToCopy = .Range("A" & i).MergeArea.EntireRow
                Else
                    Set RangeToCopy = Union(RangeToCopy, .Range("A" & i).MergeArea.EntireRow)
                End If
            End If
        Next i
    End With
    
    '~~> Copy them across. You can insert them as well
    If Not RangeToCopy Is Nothing Then
        RangeToCopy.Copy wsOuput.Rows(num)
    End If
End Sub

IN ACTION

Thanks for the advice and the script! I'll check the suggested link. — Andrés diego Menéndez, Sep 29 '20 at 14:13

Victor19 · Accepted Answer · 2020-09-29T06:09:34.067

You need to include the merge area before "Select". After you copy the rows, you need to count how many merged rows in the copy. I add a new variable num2 to do so. The loop cannot just simply num=num+1, it varies from what rows copied. You may try the below code.

Sub attributes()
'--------------------------------------------------------------------
    Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
    Dim strAsses1 As Boolean
    Dim num As Integer
    Dim num2 As Integer
    Set ws = ActiveWorkbook.Sheets("Contract Attributes")
    Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
    ws.Activate
    Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
    strName1 = InputBox("Which contract modification would you like to review?")
    num = 5
    For Each Cel In aCell1
        
        If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
            Range(Cells(Cel.Row, 1), Cells(Cel.Row, Cells(Cel.Row, Columns.Count).End(xlToLeft).Column)).Select
            num2 = Selection.Rows.Count
            Selection.EntireRow.Copy
            ws0.Activate
            Rows(num).Insert
            ws.Activate
            num = num + num2
        End If
    Next Cel
End Sub

Script to Copy and paste entirerows and mergedrows?

2 Answers2