CODEWITHSUNDEEP
excelvba
Ragdecorp
Ragdecorp

Reputation: 11

Copy and Paste various cells to another sheet when condition met

I need a little help because I´m trying to Copy and Paste selected cells from the same row to another sheet when condition are met, but I'm kind of lost, I hope you can help me

for example, I have the datasheet called sheet7 that contain data range(A4 to AF40) and my condition is that can copy and paste all rows that met Column E = "Contract" but to be able to copy some other cells, for example, columns D, G, O, and V

I want to pass all that data to a new sheet called sheet10

I hope it has been clear, and I hope you can help me

Private Sub CommandButton2_Click()
    
    Dim range1 As Range
    Dim Cell As Range
    
    Set range1 = Sheet1.Range("E4:E100")

    For Each Cell In range1
        If Cell.Value = "Contract" Then
            With Sheet7
                .Range(.Cells(Cell.Row, "C"), .Cells(Cell.Row, "F")).Copy _
                    Sheet10.Range("B100").End(xlUp).Offset(1, 0)
            End With
        End If
    Next

End Sub

Upvotes: 1

Views: 174

Answers (1)

VBasic2008
VBasic2008

Reputation: 54777

Copy Intersecting Rows and Columns

Option Explicit

Private Sub CommandButton2_Click()

    ' Lookup Range
    Dim llRow As Long
    llRow = Sheet1.Range("E" & Sheet1.Rows.Count).End(xlUp).Row
    Dim lrg As Range: Set lrg = Sheet1.Range("E4:E" & llRow)
    
    ' Source Columns Range
    Dim scrg As Range
    With Sheet7
        Set scrg = Union(.Columns("D"), .Columns("G"), _
            .Columns("O"), Columns("V"))
    End With
    
    ' Destination Cell
    Dim dfCell As Range
    Set dfCell = Sheet10.Range("B" & Sheet10.Rows.Count).End(xlUp).Offset(1, 0)
    
    Dim srg As Range ' Source Range
    Dim lCell As Range ' Lookup Cell

    For Each lCell In lrg.Cells
        If StrComp(CStr(lCell.Value), "Contract", vbTextCompare) = 0 Then
            ' Combine cell into a range.
            If srg Is Nothing Then
                Set srg = Sheet7.Cells(lCell.Row, "A")
            Else
                Set srg = Union(srg, Sheet7.Cells(lCell.Row, "A"))
            End If
        End If
    Next lCell
    
    If srg Is Nothing Then Exit Sub
    
    Set srg = Intersect(srg.EntireRow, scrg)
    
    srg.Copy dfCell

End Sub

Upvotes: 1

Related Questions