如何在满足多个标准后创建词典项目

Question

这是我想要实现的目标：

开SheetA我在列H中有一个唯一的ID。在列CK中，我有一些数据行，有些行没有数据。

SheetB具有匹配的唯一ID到第一张（不是相同的顺序），ID也在第H行。

我需要查看SheetA上的所有列CK（每月的行数变化），对于找到的所有空单元格，我需要执行以下操作：

- 在SheetB上查找唯一ID - ＆gt;检查列N的特定值（ABC） - ＆gt;将列AG中的值从此行添加到字典中，其中ID（列H）为键，项目为AG中的值。

Sheet2将有多个具有相同ID的行，一些将在COlumn N中具有ABC，而其他行将具有不同的值。不应将非ABC值添加到字典中，如果找到两个或多个相同ID的ABC行，我想将列AG中找到的两个值相加。最终结果应该是一个键（ID）和一个键项，它是SheetB上所有linss的SUM，它在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。我不确定如何纳入第二个＆＃34;检查＆＃34;在SheetB上，用于匹配ID和ABC值。我认为这需要在创建任何键/项之前完成，但是在创建另一个IF语句时没有运气。

最佳， 麦克

Answer 1

尝试以下方法。如果有任何错别字，我打字就这么道歉。

基本上，我创建了两个词典。一个用于> pkcs11js@1.0.13 install /home/user/Documents/fabric-sdk-rest/packages/loopback-connector-fabric/node_modules/pkcs11js > node-gyp rebuild gyp ERR! configure error gyp ERR! stack Error: EACCES: permission denied, mkdir '/home/user/Documents/fabric-sdk-rest/packages/loopback-connector-fabric/node_modules/pkcs11js/build' gyp ERR! System Linux 4.8.0-36-generic gyp ERR! command "/usr/bin/node" "/usr/lib/node_modules/npm/node_modules/node-gyp/bin/node-gyp.js" "rebuild" gyp ERR! cwd /home/user/Documents/fabric-sdk-rest/packages/loopback-connector-fabric/node_modules/pkcs11js gyp ERR! node -v v9.5.0 gyp ERR! node-gyp -v v3.6.2 gyp ERR! not ok npm ERR! code ELIFECYCLE npm ERR! errno 1 npm ERR! pkcs11js@1.0.13 install: `node-gyp rebuild` npm ERR! Exit status 1 npm ERR! npm ERR! Failed at the pkcs11js@1.0.13 install script. npm ERR! This is probably not a problem with npm. There is likely additional logging output above. npm ERR! A complete log of this run can be found in: npm ERR! /home/user/.npm/_logs/2018-02-12T22_26_40_864Z-debug.log ，它将sheetA作为键，并将相关空格的范围地址的连接字符串作为值。对于ID，另一个词典以sheetB为关键，每个ID的总计为ID，其中CK列为空，sheetA为sheetB 1}}列"ABC"中的N为值。

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

注意：

1）Tbh ......函数和subs应该只做一件事。单一责任原则，所以你可能会考虑按照这些方式重构这一点。一个直接的机会是获得每张纸的最后一行。这可以被拉出到它自己的函数中，它在调用时返回最后一行，参数为sheet和column。

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

测试用例我跑了：