Excel VBA Paste Non-Empty Array Items into Cell Range Containing Formulas

Question

I have two columns of data in a spreadsheet. Column A has either cells containing "X" or empty cells and Column B contains formulas. I want to use VBA to pull Column A into an array, and paste the array into Column B, making sure the "X"s copy over but the empty array elements do not.

The method I have looks at each array element and if it is an "X" then paste that 1 element, it works but its slow for large data pools. Is there a faster method?

See code below:

Option Explicit

Sub Test()

Dim array1 As Variant, i As Integer
array1 = Sheets("Sheet1").Range("A2:A8").Value
For i = 1 To UBound(array1)
    If array1(i, 1) = "X" Then
        Sheets("Sheet1").Cells(i + 1, 2) = array1(i, 1)
    End If
Next i

End Sub

Answer 1

use a second array to hold the formula in B. Then iterate both arrays and replace the second with the value where needed:

Sub Test()
    With Sheets("Sheet1")
        Dim aArr() As Variant
        aArr = .Range("A2:A8").Value
        
        Dim bArr() As Variant
        bArr = .Range("B2:B8").Formula
        
        Dim i As Long
        For i = 1 To UBound(aArr, 1)
            If aArr(i, 1) = "X" Then
                bArr(i, 1) = aArr(i, 1)
            End If
        Next i
        
        .Range("B2:B8").Formula = bArr
    End With
        
End Sub

Answer 2

Replace Formulas with Criteria

It is assumed that

• the worksheet is in ThisWorkbook , the workbook containing this code,
• the Data Column is adjacent to the right of the Criteria Column , which is defined by FirstCellAddress ,
• the 'search' for the Criteria ( X ) is case-sensitive ie X <> x .

The Code

Option Explicit

Sub replaceFormulasWithCriteria()
    
    Const wsName As String = "Sheet1"
    Const FirstCellAddress As String = "A2"
    Const Criteria As String = "X"
    
    ' Define Criteria Column Range.
    Dim rng As Range
    With ThisWorkbook.Worksheets(wsName).Range(FirstCellAddress)
        Set rng = .Resize(.Worksheet.Cells(.Worksheet.Rows.Count, .Column) _
            .End(xlUp).Row - .Row + 1)
    End With
    ' Write values from Criteria Column Range to Criteria Array.
    Dim Crit As Variant: Crit = rng.Value
    ' Define Data Column Range.
    Set rng = rng.Offset(, 1)
    ' Write formulas from Data Column Range to Data Array.
    Dim Data As Variant: Data = rng.Formula
    
    Dim i As Long
    ' Loop through rows of Criteria/Data Column Range.
    For i = 1 To UBound(Data, 1)
        ' Check if Criteria is found in current row in Criteria Array.
        If Crit(i, 1) = Criteria Then
            ' Write Criteria to current row in Data Array.
            Data(i, 1) = Criteria
        End If
    Next i
    
    ' Write modified values from Data Array to Data Column Range.
    rng.Value = Data
    ' or:
    'rng.Formula = Data

End Sub