如何仅在满足多个条件后创建字典项

Question

这是我想要达到的目标：

在SheetA 上，我在 H 列中有一个唯一 ID。在 CK 列中，我有一些行包含数据，一些行没有数据。

SheetB 具有与第一页匹配的唯一 ID（顺序不同），并且 ID 也在 H 行中。

我需要遍历SheetA 上的所有 CK 列（每个月的行数不同），对于找到的所有空单元格，我需要执行以下操作：

-在SheetB 上查找唯一 ID --> 检查 N 列的特定值 (ABC) --> 将在 AG 列中找到的值从该行添加到以 ID（H 列）为键的字典中，然后该项目作为 AG 中的值。

Sheet2 将有多个具有相同 ID 的行，一些将在 COlumn N 中具有 ABC，其他将具有不同的值。不应将非 ABC 值添加到字典中，如果为同一 ID 找到两条或更多条 ABC 行，我想将在 AG 列中找到的两个值相加。最终结果应该是一个密钥 (ID) 和一个密钥项，该密钥将是 SheetB 上所有 linss 的总和，这些 linss 在 Col. H 中具有唯一 ID，在 Col. N 中具有 ABC。

然后我需要将值放在 CK 列的空白单元格中的 SheetA 上，而不覆盖其中已经包含数据的任何行。

以下是我目前的代码：

Dim ws As Worksheet

Set ws = Worksheets("SheetA")

Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRowForDict4 As Long, LastRowResult4 As Long 
Dim p As Long

 Set dict = CreateObject("Scripting.Dictionary")

Dim wsYTD As 

 Set wsYTD = Worksheets("SheetB")

With ws

    LastRowForDict4 = .Range("B" & rows.Count).End(xlUp).Row

For p = 1 To LastRowForDict4
If IsEmpty(ws.Range("CK" & p)) = True Then ' And wsYTD.Range("N" & p).Value = "ABC"  'only adds to dictionary if lines has blank value on Column CK but the commented out code does not work because the ID's are not on the same rows on the two different sheets involved



    x = wsYTD.Range("H1:H" & LastRowForDict4).Value
    x2 = wsYTD.Range("AG1:AG" & LastRowForDict4).Value


        'If key exists already ADD new value (SUM them)

If Not dict.Exists(x(p, 1)) Then
    dict.Item(x(p, 1)) = x2(p, 1)
Else
   dict.Item(x(p, 1)) = CDbl(dict.Item(x(p, 1))) + CDbl(x2(p, 1))
End If

End If
Next p


End With


 'map the values
 With ws
    LastRowResult = .Range("B" & rows.Count).End(xlUp).Row
    y = .Range("H2:H" & LastRowResult).Value    'looks up to this range
    ReDim y2(1 To UBound(y, 1), 1 To 1)   '<< size the output array
    For i = 1 To UBound(y, 1)
        If dict.Exists(y(i, 1)) Then
            y2(i, 1) = dict(y(i, 1))


        End If
    Next i
    .Range("CK2:CK" & LastRowResult).Value = y2  '<< place the output on the sheet
End With

我知道至少部分问题在于我在代码中评论过的 If IsEmpty(ws.Range("CK" & p)) = True Then 这一行。我不确定如何在SheetB 上合并第二个“检查”以匹配 ID 和 ABC 值。我认为这需要在创建任何键/项之前完成，但是没有运气创建另一个 IF 语句。

最好， 迈克

Answer 1

试试下面的。如果有错别字，我很抱歉。

基本上，我创建了两个字典。一个用于sheetA，它将ID 作为键，并将相关空白的范围地址的串联字符串作为值。另一个字典，对于sheetB，以ID 作为键，每个ID 的总数，其中CK 列在sheetA 中为空白，sheetB 在N 列中具有"ABC" , 作为值。

然后，我使用一个字典 ID 将总数清空到空白范围中以访问另一个字典。

注意事项：

1) Tbh... 函数和子函数实际上应该只做一件事。单一职责原则，因此您可能会考虑按照这些思路进行重构。一个直接的机会是获取每张纸的最后一行。这可以被提取到它自己的函数中，该函数在调用时返回最后一行，带有工作表和列的参数。

2) 您可能还需要在其中进行一些数据类型验证，以确保您正在处理的值是预期的类型并且不存在数据质量问题。我没有包括任何错误处理。

如果需要，很高兴添加更多评论。

Option Explicit

Public wb As Workbook
Public wsA As Worksheet
Public wsB As Worksheet

Public Sub PopulateBlanksCells()

    Set wb = ThisWorkbook
    Set wsA = wb.Worksheets("SheetA")
    Set wsB = wb.Worksheets("SheetB")

    Dim shtADict As Dictionary
    Set shtADict = UniqueIDdict

    Dim shtBDict As Dictionary

    Set shtBDict = GetSumSheetBDict(shtADict)

    Dim key As Variant
    Dim rngArray() As String
    Dim item As Long
    Dim total As Long

    For Each key In shtBDict.Keys

        rngArray = Split(shtADict(key), ";")     ', shtBDict(key)

        If UBound(rngArray) = 0 Then
            total = 0
        Else
            total = UBound(rngArray) - 1
        End If

        For item = LBound(rngArray) To total

            wsA.Range(rngArray(item)) = shtBDict(key)

        Next item

    Next key

End Sub

Public Function GetSumSheetBDict(ByVal shtADict As Dictionary) As Dictionary 

    Dim lastRowSheetB As Long

    lastRowSheetB = wsB.Cells(wsB.Rows.Count, "H").End(xlUp).Row

    Dim sheetBArr() As Variant
    sheetBArr = wsB.Range("H2:AG" & lastRowSheetB).Value

    Dim key As Variant
    Dim j As Long
    Dim shtBDict As Dictionary
    Set shtBDict = New Dictionary

    For Each key In shtADict.Keys

        For j = LBound(sheetBArr, 1) To UBound(sheetBArr, 1)

            If sheetBArr(j, 1) = key And sheetBArr(j, 7) = "ABC" Then


                If Not shtBDict.Exists(key) Then

                    shtBDict.Add key, sheetBArr(j, 26)

                Else

                    shtBDict(key) = shtBDict(key) + sheetBArr(j, 26)

                End If


            End If


        Next j

    Next key

    Set GetSumSheetBDict = shtBDict

End Function

Public Function UniqueIDdict() As Dictionary

    Dim lastRowSheetA As Long

    lastRowSheetA = wsA.Cells(wsA.Rows.Count, "H").End(xlUp).Row

    Dim sheetAArr() As Variant
    sheetAArr = wsA.Range("H2:CK" & lastRowSheetA).Value

    'Create first dict with ID and Address of those where ID blank

    Dim shtADict As Scripting.Dictionary
    Set shtADict = New Scripting.Dictionary

    Dim currID As Long

    For currID = LBound(sheetAArr) To UBound(sheetAArr)

        Dim colCK As Variant
        Dim ID As Variant
        colCK = sheetAArr(currID, UBound(sheetAArr, 2))
        ID = sheetAArr(currID, 1)

        If IsEmpty(colCK) Then 

            If Not shtADict.Exists(ID) Then

                shtADict.Add ID, "CK" & currID + 1 & ";"

            Else

                 shtADict(ID) = shtADict(ID) & "CK" & currID + 1 & ";"

            End If

        End If

    Next currID

    Set UniqueIDdict = shtADict

End Function

我运行的测试用例：