vba - 根据另一列中的条件填充上方和下方的空白单元格

Question

我有以下列和值:

User ID     Input B    Input C    Input D     ...   Input ZZ

id_value1              c_value1                     
id_value1                                          
id_value1                         d_value1          zz_value1
id_value1   b_value1                                
id_value2   b_value2                                
id_value2                                           zz_value2
id_value2              c_value2   d_value2          
id_value2                                           
id_value2                                           
id_value3              c_value3                     
id_value3   b_value3              d_value3          zz_value3
id_value4                                           
id_value4   b_value4                                        
id_value4                                           zz_value4
id_value4              c_value4   d_value4
id_value4                      

我想实现以下目标:

User ID     Input B    Input C    Input D     ...   Input ZZ

id_value1   b_value1   c_value1   d_value1          zz_value1
id_value1   b_value1   c_value1   d_value1          zz_value1
id_value1   b_value1   c_value1   d_value1          zz_value1
id_value1   b_value1   c_value1   d_value1          zz_value1
id_value1   b_value1   c_value1   d_value1          zz_value1
id_value2   b_value2   c_value2   d_value2          zz_value2
id_value2   b_value2   c_value2   d_value2          zz_value2
id_value2   b_value2   c_value2   d_value2          zz_value2
id_value2   b_value2   c_value2   d_value2          zz_value2
id_value2   b_value2   c_value2   d_value2          zz_value2
id_value3   b_value3   c_value3   d_value3          zz_value3
id_value3   b_value3   c_value3   d_value3          zz_value3
id_value4   b_value4   c_value4   d_value4          zz_value4
id_value4   b_value4   c_value4   d_value4          zz_value4
id_value4   b_value4   c_value4   d_value4          zz_value4
id_value4   b_value4   c_value4   d_value4          zz_value4
id_value4   b_value4   c_value4   d_value4          zz_value4

目标是这样的:

在 A 列中具有相同值的每组行中(这些行是连续的)，使用 B:ZZ 列中存在的单个值实例来填充这些列中上下的任何空白单元格。

换句话说，对于 B:ZZ 列中的任何值，向上和向下填充该值，直到 A 列中的值发生变化。

换一种说法，对于任何空白单元格，在 rc1 的上方或下方找到一个具有匹配值的非空白单元格并获取该单元格的值。

我的伪代码方法如下:

for each blankcell:
    find nonblank above
    if nonblank.rc1 == blankcell.rc1:
       blankcell == nonblank
    else find nonblank below
    if nonblank.rc1 == blankcell.rc1:
       blankcell == nonblank
    else do nothing

这看起来比较简单，但我不知道如何在 VBA 中实现它。

我一直在尝试修补 @Jeeped's code用于解决类似问题，但尚未成功。

Private Sub FillColBlanksSpecial2()

    Dim wks As Worksheet
    Dim rng As Range
    Dim rng2 As Range
    Dim blnk As Range
    Dim LastRow As Long
    Dim col As Long
    Dim lRows As Long
    Dim lLimit As Long

    Dim lCount As Long
    On Error Resume Next

    lRows = 2
    lLimit = 1000

    Set wks = ActiveSheet
        With wks
            With .Cells(1, 1).CurrentRegion
                With .Columns("B:ZZ")
                    If CBool(Application.CountBlank(.Cells)) Then
                        For Each blnk In .SpecialCells(xlCellTypeBlanks)
                            blnk.FormulaR1C1 = "=if(countifs(r1c1:r[-1]c1, rc1, r1c:r[-1]c, ""<>""), index(r1c:r[-1]c, match(rc1, r1c1:r[-1]c2, 0)), if(countifs(r[1]c1:r9999c1, rc1, r[1]c:r9999c, ""<>""), index(r[1]c:r9999c, min(index(row(r:r9998)-row(r[-1])+((r[1]c1:r9999c1<>rc1)+not(len(r[1]c:r9999c)))*1e+99, , ))), r[-1]c))"

                            blnk.Value = blnk.Value
                        Next blnk
                    End If
                End With
            End With
        End With
End Sub

据我了解，此代码根据 A 列中的值向上填充，但向下填充，直到找到任何新值(不依赖于 A 列条件)。我也对使用代码犹豫不决，因为我不了解 min() 函数的逻辑。

任何有关如何实现我的伪代码方法或任何替代方法的见解将不胜感激。

Answer 1

也许尝试类似下面的东西？

Sub FillValues()

    Dim tempRange As Range, tempArray As Variant, rowStart As Long, rowEnd As Long, lastRow As Long, lastCol As Long
    Dim i As Long, j As Long, tempValue As Variant

    ' The assumption is that we are starting in row 2, and go as far down as there are cells in Column A
    ' Also that we are using Column A as a reference.
    ' So we start by getting this range and assigning it to our variable.
    lastRow = Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row
    lastCol = ActiveSheet.UsedRange.Columns.Count
    Set tempRange = Intersect(ActiveSheet.UsedRange, Range("A2:A" & lastRow).EntireRow)

    ' We are going to assume that we are not concerned about pasting formats etc.
    '(If we are concerned with that, we would need to change our code)
    'Set the tempArray to be this range that we acquired above.
    tempArray = tempRange.Value

    rowStart = 1
    While rowStart <= lastRow

        rowEnd = rowStart

        ' First get the rows we are going to be looking at
        ' Keep iterating rowEnd until we find a new value, or we reach the end
        While tempArray(rowEnd, 1) = tempArray(rowStart, 1) And rowEnd < lastRow
            rowEnd = rowEnd + 1
        Wend
        ' If we did reach a new value, go back one to get the real row range.
        If Not tempArray(rowEnd, 1) = tempArray(rowStart, 1) Then rowEnd = rowEnd - 1

        ' Now that we have a range, we loop over the row range and column range.

        ' For each column
        For j = 2 To lastCol

            ' Cycle through the rows to find an acceptable value
            tempValue = ""
            For i = rowStart To rowEnd
                If Not Len(tempArray(i, j)) = 0 Then tempValue = tempArray(i, j): Exit For
            Next i

            ' If we found a value, populate the whole section accordingly
            If Not Len(tempValue) = 0 Then
                For i = rowStart To rowEnd
                    tempArray(i, j) = tempValue
                Next i
            End If

        Next j

        ' After we did this for each column, we now need to iterate to the next section
        rowStart = rowEnd + 1

    Wend

    ' Finally we put the new data back into the sheet
    tempRange = tempArray

    ' And clear the variables
    Set tempRange = Nothing: Set tempArray = Nothing

End Sub