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

Stackoverflow Code我已经适应分别使用1和24。

 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

试试这个。根据评论修改了列引用，而且我认为您的第一个循环不必要地长。如果您的阵列实际上具有不同的大小，则需要更改24秒。

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

根据C列中的条件查找缺失值

3 个答案: