根據 C 列中的條件查找缺失值

Question

我在 C 列中有一個值，該值在某些情況下是重復的，其中存在重復項我希望它在 Z 列中查找相應的 ID，如果不存在我希望它檢查 C 列中的任何其他值是否有值Z 列，然后相應地將缺失值添加到 Z 列中：

Column C         Column Z   
45519            Blank*
45519            1 
456              2
456              *Blank

預期結果：

Column C:        Column Z
45519                1
45519                1
456                  2
456                  2

我已經適應分別使用 1 和 24 的 Stackoverflow 代碼。

 Sub test()

 Dim wb As Workbook
 Set wb = ThisWorkbook
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Worksheets("transactions")
 lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
 Dim dataArr()
 dataArr = ws.Range("C1:Z" & lastRow).Value
 Dim currentRow As Long
 Dim dict As Object

 Set dict = CreateObject("Scripting.Dictionary")
 For currentRow = LBound(dataArr, 1) To UBound(dataArr, 2)
 If Not IsEmpty(dataArr(currentRow, 2)) And Not dict.Exists(dataArr
 (currentRow, 1)) Then
    dict.Add dataArr(currentRow, 1), dataArr(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)

If IsEmpty(dataArr(currentRow, 2)) Then

    dataArr(currentRow, 2) = dict(dataArr(currentRow, 1))
 End If

Next currentRow

ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr

End Sub

因此，我在 Z 列中沒有收到任何結果

Answer 1

嘗試這個。 根據評論修改了列引用，而且我認為您的第一個循環不必要地長。 如果您的數組實際上具有不同的大小，則需要更改 24s。

Option Explicit

Sub test()

Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object

Set dict = CreateObject("Scripting.Dictionary")

For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
    If Not IsEmpty(dataArr(currentRow, 24)) And Not dict.Exists(dataArr(currentRow, 1)) Then
        dict.Add dataArr(currentRow, 1), dataArr(currentRow, 24)
    End If
Next currentRow

For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
    If IsEmpty(dataArr(currentRow, 24)) Then
        dataArr(currentRow, 24) = dict(dataArr(currentRow, 1))
    End If
Next currentRow

ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr

End Sub

替代方法

Sub test()

Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

Dim r As Range, r1 As Range, s As String

For Each r In ws.Range("Z1:Z" & lastRow).SpecialCells(xlCellTypeBlanks)
    Set r1 = ws.Range("C1:C" & lastRow).Find(ws.Cells(r.Row, "C"), , , xlWhole)
    If Not r1 Is Nothing Then
        s = r1.Address
        Do Until r1.Row <> r.Row
            Set r1 = ws.Range("C1:C" & lastRow).FindNext(r1)
            If r1.Address = s Then Exit Do
        Loop
        r.Value = ws.Cells(r1.Row, "Z")
    End If
Next r

End Sub

Answer 2

有一些整理工作要做。 當前假設數據從第 2 行開始。

Option Explicit

Public Sub test()

    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("transactions")
    Dim lastRow As Long

    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    Dim unionRng As Range
    Set unionRng = Union(ws.Range("C2:C" & lastRow), ws.Range("Z2:Z" & lastRow))

    Dim dataArray()
    Dim numberOfColumns As Long
    numberOfColumns = unionRng.Areas.Count

    ReDim dataArray(1 To lastRow, 1 To numberOfColumns) '1 could come out into variable startRow
    Dim currRow As Range

    Dim columnToFill As Long

    For columnToFill = 1 To numberOfColumns

        For Each currRow In unionRng.Areas(columnToFill)

            dataArray(currRow.Row - 1, columnToFill) = currRow 'assume data starts in row 1 otherwise if 2 then currRow.Row -1 etc

        Next currRow

    Next columnToFill


    Dim currentRow As Long
    Dim dict As Object

    Set dict = CreateObject("Scripting.Dictionary")

    For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)

        If Not IsEmpty(dataArray(currentRow, 2)) And Not dict.Exists(dataArray(currentRow, 1)) Then
            dict.Add dataArray(currentRow, 1), dataArray(currentRow, 2)
        End If

    Next currentRow

    For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)

        If IsEmpty(dataArray(currentRow, 2)) Then

            dataArray(currentRow, 2) = dict(dataArray(currentRow, 1))
        End If

    Next currentRow

    ws.Range("Z2").Resize(UBound(dataArray, 1), 1) = Application.Index(dataArray, 0, 2)

End Sub

Answer 3

你可以很簡單地像下面這樣

Option Explicit

Sub main()
    Dim cell As Range, IdsRng As Range

    With Worksheets("transactions") 'reference wanted sheet
        Set IdsRng = .Range("Z2", .Cells(.Rows.Count, "Z").End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) 'get all IDs from its column Z cells with constant numeric value

        With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference referenced sheet column C cells from row 1 (header) down to last not empty one
            For Each cell In IdsRng 'loop through all IDs
                .AutoFilter Field:=1, Criteria1:=cell.Offset(, -23).value ' filter referenced cells on 1st column with passed ID content 'filter referenced range with current ID
                .Offset(1, 23).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value = IdsRng.value 'write all filtered cells corresponding values in column Z with current ID
            Next
        End With
        .AutoFilterMode = False
    End With
End Sub