Question

我有以下要求我有2列，其中包含称为代码的唯一键。在代码下面的一列中，存在一个或多个值作为答案。喜欢以下格式

A X
1
2
B Y
9
3

现在代码将在下一列填充一个值，而答案不会。

现在我必须找到所有代码的答案，例如A，B，C等。例如，如果我与A比较那么答案应该是1,2。我正在写一个小的子程序作为开始，但我面临着问题。你可以纠正吗

Sub CalculateCellValue()
Dim ValuesBelow As Variant
Dim ValuesRight As String
Dim rows1 As Integer
rows1 = 4
Dim colC As Integer
colC = 2
ValuesRight = ActiveSheet.Cells(rows1 + 1, colC + 1)

While (Not IsEmpty(ValuesRight))
 ValuesBelow = ActiveSheet.Cells(rows1 + 1, colC)
 rows1 = rows1 + 1
 ValuesRight = ActiveSheet.Cells(rows1 + 1, colC + 1)
Wend
MsgBox (ValuesBelow)
End Sub

Answer 1

纯粹是为了一个有序的例子，如下所示：

Option Explicit

Sub test()

    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet5")             'Change as appropriate

    Dim myArr()

    myArr = ws.Range("A1:B" & GetLastRow(ws, 1)).Value

    Dim i As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    For i = LBound(myArr, 1) To UBound(myArr, 1)

        If myArr(i, 2) <> vbNullString Then

            If Not dict.exists(myArr(i, 1)) Then
                Dim currKey As String
                currKey = myArr(i, 1)
                dict.Add myArr(i, 1), vbNullString
            End If

        Else

            dict(currKey) = dict(currKey) & ", " & myArr(i, 1)

        End If

    Next i

    Dim key As Variant

    For Each key In dict
        MsgBox key & " = " & Right$(dict(key), Len(dict(key)) - 1)
    Next key

End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long

    With ws

        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row

    End With

End Function

Answer 2

我使用下面的代码来符合我的要求

Function findBelowAll(rows1 As Long)

Dim ValuesBelow() As Variant
ReDim ValuesBelow(1 To 1) As Variant
Dim ValuesRight As Variant
Dim colC As Long
colC = 1
Dim i As Long

ValuesRight = ""

While (ValuesRight = "")
rows1 = rows1 + 1
' change / adjust the size of array
    ReDim Preserve ValuesBelow(1 To UBound(ValuesBelow) + 1) As Variant

    ' add value on the end of the array
    ValuesBelow(UBound(ValuesBelow)) = 
Worksheets(ActiveSheet.Name).Cells(rows1, colC).Value

ValuesRight = Worksheets(ActiveSheet.Name).Cells(rows1, 2).Value
Wend

For i = LBound(ValuesBelow) To UBound(ValuesBelow) - 1
    findBelowAll = findBelowAll & ValuesBelow(i) & vbNewLine
Next i

End Function

查找单元格的VBA代码与密钥匹配

2 个答案: