楼主
liuguansky |
Q：如何依其他工作簿中的替代数据据对缺失的信息进行标识解决方案？
A：用如下代码可以实现：
- Sub solution()
- Dim arr, i&, str1$, str2$, dic, arrt, j&, arrre(), arrm, arrn, k&, s&, r&, arrj()
- Set dic = CreateObject("scripting.dictionary")
- Application.ScreenUpdating = False
- Workbooks.Open (ThisWorkbook.Path & "\替代数据库.xls")‘两文件放于同一文件夹下，否则请更改OPEN后的路径。
- With ActiveWorkbook
- With .Worksheets(1)
- arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(3).Row + 1, 4).Value
- For i = 2 To UBound(arr, 1)
- str1 = "": str2 = ""
- Do While arr(i, 1) <> ""
- str1 = str1 & "|" & Trim(arr(i, 1))
- str2 = str2 & "|" & Trim(arr(i, 4))
- i = i + 1
- Loop
- dic(Mid(str1, 2)) = Mid(str2, 2)
- Next
- End With
- .Close
- End With
- With Sheet1
- arr = .Cells(2, 2).Resize(.Cells(.Rows.Count, 2).End(3).Row - 1, 2).Value
- arrt = dic.keys: arrs = dic.items
- For i = 1 To UBound(arr, 1)
- For j = 0 To UBound(arrt)
- If InStr(1, "|" & arrt(j) & "|", "|" & arr(i, 1) & "|") > 0 Then
- arr(i, 1) = arrt(j)
- If InStr(1, dic(arrt(j)), vbTab) > 0 Then
- dic(arrt(j)) = Split(dic(arrt(j)), vbTab)(0) & vbTab & Split(dic(arrt(j)), vbTab)(1) + arr(i, 2)
- Else: dic(arrt(j)) = dic(arrt(j)) & vbTab & arr(i, 2)
- End If
- Exit For
- End If
- Next j, i
- ReDim arrre(1 To UBound(arr, 1))
- For i = 1 To UBound(arr, 1)
- If dic.exists(arr(i, 1)) Then
- arrm = Split(dic(arr(i, 1)), vbTab)
- arrn = Split(arrm(0), "|")
- k = CInt(arrm(1))
- ReDim arrj(UBound(arrn))
- For j = 0 To UBound(arrn)
- arrj(j) = CInt(arrn(j))
- Next j
- s = Application.Sum(arrj)
- r = Application.Max(arrj)
- If k <= r Then
- For j = 0 To UBound(arrj)
- If arrj(j) = r Then Exit For
- Next j
- arrre(i) = "可用" & Split(arr(i, 1), "|")(j) & "来进行替代" & k & "个"
- ElseIf k <= s Then
- arrre(i) = "可用" & arr(i, 1) & "中的多个组合来替换" & k & "个"
- Else: arrre(i) = "可用" & arr(i, 1) & "中的多个组合来替换" & s & "个，但依然有" & k - s & "个不足"
- End If
- Else: arrre(i) = "No Solution"
- End If
- Next i
- .Range("d2:d" & .Rows.Count).ClearContents
- .Cells(2, 4).Resize(i - 1, 1) = Application.Transpose(arrre)
- End With
- Application.ScreenUpdating = True
- Set dic = Nothing
- End Sub
运行后效果如下图：
具体示例文件如下：
|