CODEWITHSUNDEEP
excelvbaexcel-formula
reydelpueblo
reydelpueblo

Reputation: 13

How to add cell conditions to VBA copy/paste macro (i.e., copy/paste when cells in range = "Yes")

Background

Goal I would only like to paste values from Sheet A into Sheet B only when cells in Sheet A, Column P contain the value "Yes!". Not sure how to incorporate that condition into my current macro:

Current Work

The macro below pastes all values to/from specified sheets/cells regardless of values in Sheet A,Column P. I cannot condition this on respective rows in Sheet A,Column P containing the value "Yes!". Basically Sheet A,Column P describes the data in Sheet A,Columns Q-AA, and therefore only data that meet that criteria needs to be copied and pasted to Sheet B.

Sub copy_sheetA_to_sheetB()

Dim OneRng As Range
  Set OneRng = Sheets("Sheet A").Range("Q2:AA" & Cells(Rows.Count, "A").End(xlUp).Row)
      OneRng.copy
      Sheets("Sheet B").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
      
  
  Application.CutCopyMode = False

End Sub

Upvotes: 1

Views: 222

Answers (2)

VBasic2008
VBasic2008

Reputation: 54948

Copy Criteria Values

enter image description here enter image description here

Sub CopyAtoB()
    
    ' Define constants.
    
    Const SRC_SHEET As String = "Sheet A"
    Const SRC_FIRST_LOOKUP_CELL As String = "P2"
    Const SRC_COPY_COLUMNS As String = "Q:AA"
    Const DST_SHEET As String = "Sheet B"
    Const DST_FIRST_CELL As String = "A2"
    Const CRITERIA_STRING As String = "Yes!" ' case-insensitive
    
    ' Reference the workbook.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    If sws.FilterMode Then sws.ShowAllData
    
    Dim slrg As Range, srCount As Long
    
    With sws.Range(SRC_FIRST_LOOKUP_CELL)
        Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not slCell Is Nothing Then
            srCount = slCell.Row - .Row + 1
            Set slrg = .Resize(srCount)
        End If
    End With
    
    If srCount = 0 Then
        MsgBox "No data found.", vbExclamation
        Exit Sub
    End If
    
    Dim scrg As Range: Set scrg = slrg.EntireRow.Columns(SRC_COPY_COLUMNS)
    Dim cCount As Long: cCount = scrg.Columns.Count
    
    ' Write the values from the source range to the Data array.
    Dim Data(): Data = scrg.Value
    
    ' Return the matches in a 2D one-based single-column array
    ' of the same size as the size of the source lookup range.
    ' Matches will return 1 while non-matches will return an error value.
    
    Dim srMatches():
    srMatches = Application.Match(slrg, Array(CRITERIA_STRING), 0)
    
    If Application.Count(srMatches) = 0 Then
        MsgBox "No criteria matches found.", vbCritical
        Exit Sub
    End If
    
    ' Write the matching rows to the top of the Data array.
    
    Dim sr As Long, c As Long, dr As Long
    
    For sr = 1 To srCount
        If IsNumeric(srMatches(sr, 1)) Then
            dr = dr + 1
            For c = 1 To cCount
                Data(dr, c) = Data(sr, c)
            Next c
        End If
    Next sr
    
    ' Reference the destination range.
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    If dws.FilterMode Then dws.ShowAllData
    
    Dim dfCell As Range
    
    With dws.Range(DST_FIRST_CELL)
        Set dfCell = .Resize(dws.Rows.Count - .Row + 1) _
           .Find("*", , xlFormulas, , , xlPrevious)
        If dfCell Is Nothing Then
            Set dfCell = .Cells
        Else
            Set dfCell = dfCell.Offset(1)
        End If
    End With
    
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    
    ' Write the values from the top of the Data array to the destination range.
    
    drg.Value = Data

    ' Inform.

    MsgBox "Values copied.", vbInformation

End Sub

Upvotes: 0

Pongphon Tan
Pongphon Tan

Reputation: 46

I advise adding a for-loop and a condition:

  • a for-loop to iterate over a range i.e., OneRng to check flag in column P
  • a condition to check if the value of the target cell is as required i.e., "Yes!" before pasting. Then copy each row (excluding column P) to sheet B

Please validate and let me know if this solution is applicable. Below is an updated code snippet:

Sub copy_sheetA_to_sheetB()

  Dim OneRng As Range
  Set OneRng = Sheets("Sheet A").Range("P2:AA" & Cells(Rows.Count, "A").End(xlUp).Row) 'include column P as a flag
  For c = 1 To OneRng.Rows.Count
  If OneRng.Cells(c,1).Value  = "Yes!" Then
      OneRng.Offset(0,1).Resize(OneRng.Rows.Count, OneRng.Columns.Count-1).copy
      Sheets("Sheet B").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
  End If
  
  Application.CutCopyMode = False

End Sub

Upvotes: 1

Related Questions