CODEWITHSUNDEEP
excel
Shalini
Shalini

Reputation: 33

I want to copy specific rows if it contains certain text to another sheet using VBA

I am trying to write a macro that copies a row if a cell in that row contains text (For ex: Mumbai, Delhi etc) from Column C.

For example if there are 30 rows but only 15 contains text(Mumbai & Delhi) in column C. I want to copy those 15 rows and paste them into "Sheet2" I was using the below code. however it is copying all the filled rows. however my requirement is the code should only need to copy columns of a, b, c, d, f, g, h, i, l & m to Sheet2.

 Sub testPasteinSh2()
 Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, cel As Range
 Dim rngCopy As Range, lastR1 As Long, lastR2 As Long
 Dim strSearch1 As String, strSearch2 As String
 
 strSearch1 = "Mumbai" 'or combo value...
 strSearch2 = "Delhi"  'or something else...
 Set sh1 = ActiveSheet          'use here your worksheet
 Set sh2 = Worksheets("Sheet2") 'use here your sheet
 lastR1 = sh1.Range("C" & Rows.count).End(xlUp).Row
 lastR2 = sh2.Range("A" & Rows.count).End(xlUp).Row + 1
 
 Set rng = sh1.Range("C2:C" & lastR1)
 For Each cel In rng.cells
    If cel.Value = strSearch1 Or cel.Value = strSearch2 Then
        If rngCopy Is Nothing Then
            Set rngCopy = sh1.Rows(cel.Row)
        Else
            Set rngCopy = Union(rngCopy, sh1.Rows(cel.Row))
        End If
    End If
 Next
 If Not rngCopy Is Nothing Then
    rngCopy.Copy Destination:=sh2.cells(lastR2, 1)
 End If
End Sub

Can you please help me. Thank you in Advance.

Upvotes: 1

Views: 161

Answers (2)

Foxfire And Burns And Burns
Foxfire And Burns And Burns

Reputation: 11978

You could try this:

Sub Macro1()
Dim lastrow As Long, erow As Long


Dim rng1 As Range
Dim rng2 As Range

'choose an empty column, in my example is O.

With Worksheets("Sheet1")
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("O2:O" & lastrow).FormulaR1C1 = "=IF(OR(RC[-12]=""Mumbai"",RC[-12]=""Delhi""),1,"""")" 'here is -12 because difference between column C and O is 3. Change it according your needs
    Set rng1 = .Range("O2:O" & lastrow).SpecialCells(xlCellTypeFormulas, 1)
    
    For Each rng2 In rng1.Cells
        erow = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Row
        
        Worksheets("Sheet2").Range("A" & erow + 1 & ":M" & erow + 1) = .Range("A" & rng2.Row & ":M" & rng2.Row).Value 'this will copy the full row of data from A to M
    Next rng2

    Set rng1 = Nothing
    .Range("O2:O" & lastrow).Clear
End With

'delete the columns copied but you don't want like E, J,K
With Worksheets("Sheet2")
    .Columns("E:E").Delete
    .Columns("J:K").Delete
End With


End Sub

This code will copy the row of data and delete the columns you don't want.

In case that's not posible, then you can copy single ranges. You could replace line

Worksheets("Sheet2").Range("A" & erow + 1 & ":M" & erow + 1) = .Range("A" & rng2.Row & ":M" & rng2.Row).Value 'this will copy the full row of data from A to M

with

Worksheets("Sheet2").Range("A" & erow + 1).Value = .Range("A" & rng2.Row).Value 'a single cell

Probably you can adapt this to your needs.

enter image description here

Upvotes: 0

FaneDuru
FaneDuru

Reputation: 42236

It looks difficult to ask a clear question...

It happens I know what you need from a previous question. Supposing that you did not change your mind, please test the next code:

Sub testPasteinSh2Bis()
 Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, cel As Range
 Dim rngCopy As Range, lastR1 As Long, lastR2 As Long
 Dim strSearch1 As String, strSearch2 As String
 
 'a, b, c, d, f, g, h, i, l 'columns to be copied
 strSearch1 = "Mumbai" 'or combo value...
 strSearch2 = "Delhi"  'or something else...
 Set sh1 = ActiveSheet 'use here your worksheet
 Set sh2 = sh1.Next 'use here your sheet
 lastR1 = sh1.Range("C" & Rows.count).End(xlUp).Row
 lastR2 = sh2.Range("A" & Rows.count).End(xlUp).Row + 1
 
 Set rng = sh1.Range("C2:C" & lastR1)
 For Each cel In rng.cells
    If cel.Value = strSearch1 Or cel.Value = strSearch2 Then
        If rngCopy Is Nothing Then
            Set rngCopy = sh1.Range(sh1.Range("A" & cel.Row & ":D" & cel.Row).Address & "," & _
                   sh1.Range("F" & cel.Row & ":I" & cel.Row).Address & "," & sh1.Range("L" & cel.Row).Address)
        Else
            Set rngCopy = Union(rngCopy, sh1.Range(sh1.Range("A" & cel.Row & ":D" & cel.Row).Address & "," & _
                   sh1.Range("F" & cel.Row & ":I" & cel.Row).Address & "," & sh1.Range("L" & cel.Row).Address))
        End If
    End If
 Next
 If Not rngCopy Is Nothing Then
    rngCopy.Copy Destination:=sh2.cells(lastR2, 1)
 End If
End Sub

It should copy the columns a, b, c, d, f, g, h, i, l for the matching cases...

Upvotes: 1

Related Questions