vba - Finding the missing values based on criteria in Column C

Question

I have a value in column C which in some cases are duplicated, where there are duplicates I want it to look in column Z for the corresponding ID if none exist I want it to check where whether any other values in column C have a value in Column Z and then add the missing values into column Z accordingly:

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

Expected result:

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

Stackoverflow Code I have adapted to use 1 and 24 respectively.

 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

I am receiving no result in column Z as a result of this

Answer 1

Try this. Amended column references as per comments, plus I think your first loop was unnecessarily long. You'll need to change the 24s if your array is actually of a different size.

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

Alternative method

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