如何跨 VBA 中的多个列独立运行此检查？

Question

I have what I think is a pretty unique situation, I'm hoping someone can help me figure how to automate this.

I have thousands of columns of data, and each cell contains just a single digit. There are between 3-5 point of data per column.

Certain numbers should not exist within a column, if there is not also a duplicate of that number in the same column.

So essentially what I would like the code to do is check each column for the existence of solitary 6s, 7s, 8s, and 9s. If a column contains multiple of any of these numbers, those numbers should be left alone. If there are singles of any of those numbers, I would like them to be be replaced in the following way"

solitary "6" should turn into "1"

solitary "7" should turn into "2"

solitary "8" should turn into "3"

solitary "9" should turn into "4"

So for example, in column M, 8 should turn to 3. Nothing should change in N. Nothing should change in O since there are two 6s. In P, the 7 should change to 2. No change in R, triples or quadruples are okay.

Answer 1

Replace Specified Values Occurring Once in Column of Range

Option Explicit

Sub replaceValues()
    
    ' Write criteria and replacements to arrays.
    Dim Crit As Variant: Crit = VBA.Array(6, 7, 8, 9) ' 1D zero-based
    Dim Repl As Variant: Repl = VBA.Array(1, 2, 3, 4) ' 1D zero-based
    
    ' Define range.
    Dim rng As Range: Set rng = Range("M1:S5")
    
    ' Cover one cell only.
    If rng.Cells.CountLarge = 1 Then
        Dim CurrentMatch As Variant
        CurrentMatch = Application.Match(rng.Value, Crit, 0)
        If IsNumeric(CurrentMatch) Then
            rng.Value = Repl(CurrentMatch - 1)
        End If
        Exit Sub
    End If
    
    ' Write values from range to array.
    Dim Data As Variant: Data = rng.Value ' 2D one-based
    Dim rCount As Long: rCount = UBound(Data, 1)
    
    ' Declare additional variables to be used in the For Next loop.
    Dim cRng As Range ' Current Column Range
    Dim cMatches As Variant ' Current Matches Array
    Dim i As Long ' Rows Counter
    Dim j As Long ' Columns Counter
    
    ' Replace values.
    For j = 1 To UBound(Data, 2)
        Set cRng = rng.Columns(j)
        cMatches = Application.Match(cRng.Value, Crit, 0) ' 2D one-based
        For i = 1 To rCount
            If IsNumeric(cMatches(i, 1)) Then
                If Application.CountIf(cRng, Data(i, j)) = 1 Then
                    Data(i, j) = Repl(cMatches(i, 1) - 1)
                End If
            End If
        Next i
    Next j
    
    ' Write values from array to range.
    rng.Value = Data

End Sub

Answer 2

Yes. It is a unique situation. And a challenging one aswell.

Sub Check_And_Replace()

Dim Found() As Byte 'number of times each number has been found in the column
Dim R As Byte
Dim N As Byte
Dim Last_Col As Integer
Dim Col As Integer
Dim Col_Ltr As String
    
Last_Col = Cells(1, Columns.Count).End(xlToLeft).Column
    
For Col = 1 To Last_Col  'move through each column
    
        Col_Ltr = Replace(Cells(1, Col).Address(True, False), "$1", "")
        ReDim Found(6 To 9) 'set array elements to 0
        
        For R = 1 To 5 'move through the column
            For N = 6 To 9 'compare the value in each row with target numbers
                If Cells(R, Col) = N Then 'if there is a match
                    Found(N) = Found(N) + 1 'register the discovery
                End If
            Next N
        Next R
            
        For N = 6 To 9
            If Found(N) = 1 Then 'if the number was found only once
                Range(Col_Ltr & 1 & ":" & Col_Ltr & 5).Find(N) = N - 5 'replace
            End If
        Next N
            
Next Col

End Sub

Answer 3

You can try below approach to get the desired results. Change the code to suit your range.

Sub ReplaceSpecificDigits()
    Dim rngCheck As Range: Set rngCheck = Range("M2:S6") '\\ Set Range Reference Here for the full grid
    Dim i As Long, j As Long
    For i = 1 To rngCheck.Columns.Count
        '\\ We need to check for digits 6 to 9 with count equal to 1
        For j = 6 To 9
            If Application.CountIf(rngCheck.Columns(i), j) = 1 Then rngCheck.Columns(i).Replace j, j - 5, xlWhole
        Next j
    Next i
End Sub