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

Question

我有一个我认为非常独特的情况，我希望有人可以帮助我弄清楚如何自动化这个。

我有数千列数据，每个单元格只包含一个数字。 每列有 3-5 个数据点。

如果同一列中没有该数字的重复项，则该列中不应存在某些数字。

所以基本上我想要代码做的是检查每一列是否存在单独的 6s、7s、8s 和 9s。 如果一列包含多个这些数字中的任何一个，则应单独保留这些数字。 如果有任何这些数字的单曲，我希望它们以下列方式替换”

单独的“6”应该变成“1”

单独的“7”应该变成“2”

单独的“8”应该变成“3”

单独的“9”应该变成“4”

因此，例如，在 M 列中，8 应该变成 3。N 中应该没有任何变化。O 中应该没有任何变化，因为有两个 6。 在 P 中，7 应该变为 2。R 没有变化，三倍或四倍都可以。

Answer 1

替换范围列中出现一次的指定值

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

是的。 这是一个独特的情况。 也是一个具有挑战性的。

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

您可以尝试以下方法以获得所需的结果。 更改代码以适合您的范围。

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