如何仅在满足多个条件后才创建字典项
How to Create Dictionary Item Only After Multiple Criteria Are Met
这是我想要实现的目标：
在 SheetA 我在 H 列中有一个唯一 ID。在 CK 列中我有一些行有数据，一些行没有数据。
SheetB 具有与 sheet 匹配的唯一 ID（顺序不同）并且 ID 也在 H 行中。
我需要遍历 SheetA 上的所有 CK 列（行数每个月都不同），对于找到的所有空单元格，我需要执行以下操作：
-在 SheetB 上查找唯一 ID --> 检查 N 列的特定值 (ABC) --> 将在列 AG 中找到的值从此行添加到具有 ID 的字典（H 列) 作为键，项目作为 AG 中的值。
Sheet2 将有多个具有相同 ID 的行，有些行在第 N 列中有 ABC，有些则有不同的值。不应将非 ABC 值添加到字典中，如果为同一 ID 找到两个或多个 ABC 行，我想将在列 AG 中找到的两个值相加。最终结果应该是一个键 (ID) 和一个键项，它将是 SheetB 上所有 linss 的总和，它们在 Col. H 中具有唯一 ID，在 Col. N.[=20 中具有唯一 ID =]
然后我需要将这些值放在 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。我不确定如何将第二个 "check" 合并到 SheetB 上以匹配 ID 和 ABC 值。我认为这需要在创建任何键/项之前完成，但没有成功创建另一个 IF 语句。
最好的，
麦克
尝试以下操作。如果有错别字，我很抱歉。
本质上，我创建了两个词典。一个用于 sheetA，它将 ID 作为键，并将相关空白的 运行ge 地址的串联字符串作为值。另一个字典，对于 sheetB，以 ID 作为键，每个 ID 的总计，其中列 CK 在 sheetA 中是空白的，并且 sheetB 在 N 列中有 "ABC" 作为值。
然后我将总数清空到空白处 运行ges 使用一个词典 ID 访问另一个。
备注：
1) Tbh...函数和 subs 实际上应该只做一件事。单一职责原则，因此您可能会考虑按照这些思路进行重构。一个直接的机会是获取每个 sheet 中的最后一行。这可以拉出到它自己的函数中，即 returns 调用时的最后一行，参数为 sheet 和列。
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
测试用例一运行:
这是我想要实现的目标：
在 SheetA 我在 H 列中有一个唯一 ID。在 CK 列中我有一些行有数据，一些行没有数据。
SheetB 具有与 sheet 匹配的唯一 ID（顺序不同）并且 ID 也在 H 行中。
我需要遍历 SheetA 上的所有 CK 列（行数每个月都不同），对于找到的所有空单元格，我需要执行以下操作：
-在 SheetB 上查找唯一 ID --> 检查 N 列的特定值 (ABC) --> 将在列 AG 中找到的值从此行添加到具有 ID 的字典（H 列) 作为键，项目作为 AG 中的值。
Sheet2 将有多个具有相同 ID 的行，有些行在第 N 列中有 ABC，有些则有不同的值。不应将非 ABC 值添加到字典中，如果为同一 ID 找到两个或多个 ABC 行，我想将在列 AG 中找到的两个值相加。最终结果应该是一个键 (ID) 和一个键项，它将是 SheetB 上所有 linss 的总和，它们在 Col. H 中具有唯一 ID，在 Col. N.[=20 中具有唯一 ID =]
然后我需要将这些值放在 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。我不确定如何将第二个 "check" 合并到 SheetB 上以匹配 ID 和 ABC 值。我认为这需要在创建任何键/项之前完成，但没有成功创建另一个 IF 语句。
最好的， 麦克
尝试以下操作。如果有错别字，我很抱歉。
本质上，我创建了两个词典。一个用于 sheetA，它将 ID 作为键，并将相关空白的 运行ge 地址的串联字符串作为值。另一个字典，对于 sheetB，以 ID 作为键，每个 ID 的总计，其中列 CK 在 sheetA 中是空白的，并且 sheetB 在 N 列中有 "ABC" 作为值。
然后我将总数清空到空白处 运行ges 使用一个词典 ID 访问另一个。
备注：
1) Tbh...函数和 subs 实际上应该只做一件事。单一职责原则，因此您可能会考虑按照这些思路进行重构。一个直接的机会是获取每个 sheet 中的最后一行。这可以拉出到它自己的函数中，即 returns 调用时的最后一行，参数为 sheet 和列。
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
测试用例一运行: