CODEWITHSUNDEEP
excelvba
aksent1344
aksent1344

Reputation: 43

VBA how to copy paste specific cells if condition is met not all row

I have a code to copy paste all rows which met condition, but how to copy not all rows but specific cells from those rows? For example just A, C and D cells from row.

 Sub CopyRow_Item()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim last_row As Long
Item = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
LastRow = Sheets("Actuals").Cells.Find("*", SearchOrder:=xlByRows, 
SearchDirection:=xlPrevious).Row
last_row = Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
x = 1
Dim rng As Range
For Each rng In Sheets("Actuals").Range("A2:A" & LastRow)
    If rng = Item Then
        rng.EntireRow.Copy
        Sheets("Sheet1").Cells(last_row + x, 1).PasteSpecial xlPasteValues
        x = x + 1
    End If
  Next rng


Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Upvotes: 1

Views: 757

Answers (1)

VBasic2008
VBasic2008

Reputation: 54948

Copy Non-Contiguous Rows

  • '*** marks the spots.
Option Explicit

Sub CopyRow_Item()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Actuals")
    Dim slrCell As Range: Set slrCell = sws.Cells _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If slrCell Is Nothing Then Exit Sub ' no data
    Dim srg As Range: Set srg = sws.Range("A2:A" & slrCell.Row)
    Dim svrg As Range: Set svrg = sws.Range("A:A,B:B,D:D") '***
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
    Dim Criterion As Variant: Criterion = dws.Range("B1").Value
    Dim dCell As Range: Set dCell = dws.Columns("A") _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If dCell Is Nothing Then
        Set dCell = dws.Range("A2")
    Else
        Set dCell = dCell.Offset(1)
    End If
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range
    
    For Each sCell In srg.Cells
        If sCell.Value = Criterion Then
            Intersect(sCell.EntireRow, svrg).Copy '***
            dCell.PasteSpecial xlPasteValues
            Set dCell = dCell.Offset(1)
        End If
    Next sCell
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Upvotes: 1

Related Questions