如何将公式应用于列 vba 范围内的每个单元格？

Question

I have an excel file with a column full of numbers (occasionally there will be some text or a blank cell) for example

4
5
10
13
5

4
not applicable

9
2
1
6

I want to apply a function to that cell that does the following. If the cell value is blank or text do nothing. If the value is less that 8 then make it 8, if it is greater than or equal to 8 do nothing. So my example column would become:

8
8
10
13
8

8
not applicable

9
8
8
8

I wish to overwrite the values in the cell with the new values as opposed to preserving the original values that were in the cell.

Of course I could do =max(cell, 8) and then just copy the output down the column and the copy/paste values over the top of the column but I need to do this for multiple columns on a sheet (100's of times) so I need a good way to do this.

So far I have managed to write a macro that iterates through my sheet and selects the columns I need to update but I don't know how to actually update them.

Can I define a function and then apply it to each cell in a column? Is there a faster/more efficient way to do this.

EDIT

Code so far:

Sub updatemin()

Dim i, updatecol As Integer
updatecol = 14


For i = 1 To 100
    Columns(updatecol).Select
    'need to figure out how to make any values less than 8 into 8 for the cells in the given range before moving on to the next column to do the same.
    updatecol = updatecol + 22
Next i

End Sub

Answer 1

Update Columns

Option Explicit

Sub UpdateMin()

    Const FirstCellAddress As String = "N2"
    Const ColumnOffset As Long = 22
    Const ColumnsCount As Long = 100
    Const MinCriteria As Double = 8
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    
    Dim rg As Range
    Dim lCell As Range
    Dim rCount As Long
    
    With fCell.Resize(ws.Rows.Count - fCell.Row + 1, _
            (ColumnsCount - 1) * ColumnOffset + 1)
        Set lCell = .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Sub
        rCount = lCell.Row - .Row + 1
        Set rg = .Resize(rCount, 1)
    End With
    
    Dim Data As Variant
    Dim cValue As Variant
    Dim r As Long
    Dim c As Long
    
    For c = 1 To ColumnsCount
        With rg.Offset(, (c - 1) * ColumnOffset)
            'Debug.Print .Address
            Data = .Value
            For r = 1 To rCount
                cValue = Data(r, 1)
                If VarType(Data(r, 1)) = vbDouble Then
                    If cValue < MinCriteria Then
                        Data(r, 1) = MinCriteria
                    End If
                End If
            Next r
            .Value = Data
            '.Interior.Color = vbYellow
        End With
    Next c
    
    MsgBox "Columns updated.", vbInformation

End Sub

Answer 2

I propose to separate obtaining and processing of data. As for the latter, why not to apply a formula =IF(Data < Minimum, Minimum, Data) to numbers in a data range? To select only numbers, we can use SpecialCells .

Sub UpdateMin(Data As Range, Optional MinCriteria As Double)
Dim Numbers As Range
Dim Area As Range
Dim Formula As String
    On Error Resume Next
    Set Numbers = Data.SpecialCells(xlCellTypeConstants, xlNumbers)
    If Numbers Is Nothing Then Exit Sub
    On Error GoTo 0
    For Each Area In Numbers.Areas
        ' =IF(Area < MinCriteria, MinCriteria, Area)
        Formula = "IF(" & Area.Address & "<" & MinCriteria & "," & MinCriteria & "," & Area.Address & ")"
        Area.Value2 = Evaluate(Formula)
    Next Area
End Sub

We need to iterate over continuous areas here to calculate IF(...) as an array formula. To get the range of interest in your case I'd use this code:

Function getData() As Range
Dim Result As Range
Const DataSheet = "Sheet1"
Const first = 14
Const delta = 22
Const last = first + 99 * delta
Dim i&
    ' rebuild to your needs
    With ThisWorkbook.Worksheets(DataSheet)
        Set Result = .Columns(first)
        For i = first + delta To last Step delta
            Set Result = Union(Result, .Columns(i))
        Next i
        Set getData = Intersect(Result, .UsedRange)
    End With
End Function
 

The final part:

Sub main_macro()
    UpdateMin getData, 8
End Sub

I'm not sure if this is a good approach, because we are iterating over data twice - to select numbers and then to update them. But both parts are addressed to Excel itself. So the job, I hope, is gonna be done quickly at least in case of big chunks of numbers. The worst scenario, I think, is a regular alternation of numbers and words. Let me know about your choice and how it worked in the end.

Answer 3

Imagine the following data in column A

Use the following code to loop through all data and if it is smaller then 8 turn it into 8, omit the cells if they're not numeric or if they are empty.

Option Explicit

Public Sub Example()
    Dim ws As Worksheet  ' define your worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim LastRow As Long  ' find last used row in column A
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' update data to MinValue in the given DataRange
    UpdateValuesToMinimum MinValue:=8, DataRange:=ws.Range("A1", "A" & LastRow)
End Sub


Public Sub UpdateValuesToMinimum(ByVal MinValue As Long, ByVal DataRange As Range)
    Dim DataValues() As Variant  ' read all data into an array for faster processing
    DataValues = DataRange.Value2
    
    Dim iRow As Long  ' loop through all rows
    For iRow = LBound(DataValues, 1) To UBound(DataValues, 1)
        Dim iCol As Long  ' loop through all columns
        For iCol = LBound(DataValues, 2) To UBound(DataValues, 2)
            ' check if it is numeric and not empty
            If IsNumeric(DataValues(iRow, iCol)) And DataValues(iRow, iCol) <> vbNullString Then
                ' if data is <MinValue set it to MinValue 
                If DataValues(iRow, iCol) < MinValue Then
                    DataValues(iRow, iCol) = MinValue
                End If
            End If
        Next iCol
    Next iRow
    
    ' write array data back to the cells
    DataRange.Value2 = DataValues
End Sub

And you will get as result: