如上图所示:
我需要在某些条件下将 Wb1.coumns(1)
上的值与其他工作簿 Wb2.coumns(1)
进行匹配。
Wb2
将过滤 M
列中的值 Close
。
然后,我查找最新的截止日期并在 B
列中获取其各自的值,并将该值输入到 Wb1.column(K)
中。
下面的代码可以正确地处理所提供的示例,但它在我的实际数据集上并不可靠,
因为它取决于许多列从最旧到最新的排序。
这是link for the provided sample
Sub Get_the_respective_value_of_Last_Closing_Date()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim arr1() As Variant, arr2() As Variant
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("Path of wb2", UpdateLinks:=False, ReadOnly:=True)
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
Set rng1 = ws1.Range("A3:K" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row) 'Main Range
Set rng2 = ws2.Range("A3:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)
arr1 = rng1.Value2
arr2 = rng2.Value2
Dim i As Long, k As Long
For i = LBound(arr1) To UBound(arr1)
For k = LBound(arr2) To UBound(arr2)
If arr1(i, 1) = arr2(k, 1) And arr2(k, 13) = "Close" Then
rng1.Cells(i, 11) = arr2(k, 2)
End If
Next k
Next i
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
最佳答案
请尝试下一个改编的代码。它使用字典来保留打开的工作簿的唯一 kay(以及“K:K”中的最后一个值作为项目),然后将适当的数据放入工作工作簿中:
Sub Get_Last_Closing_Date()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim arr1() As Variant, arr2() As Variant
Dim dict As Object
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
'Please, update the real path of "Book2.xlsx":
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx", UpdateLinks:=False, ReadOnly:=True)
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
Set rng1 = ws1.Range("A3:K" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row) 'Main Range
Set rng2 = ws2.Range("A3:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)
arr1 = rng1.Value2
arr2 = rng2.Value2
'place the unique last key in a dictionary:
Dim i As Long
Set dict = CreateObject("Scripting.dictionary")
For i = 1 To UBound(arr2)
If arr2(i, 13) = "Close" Then
dict(arr2(i, 1)) = arr2(i, 2)
End If
Next i
Debug.Print Join(dict.items, "|") 'just to visualy see the result
'Place the necessary data in its place:
For i = 1 To UBound(arr1)
If dict.Exists(arr1(i, 1)) Then
arr1(i, 11) = dict(arr1(i, 1))
Else
arr1(i, 11) = "NA"
End If
Next i
rng1.Value2 = arr1 'drop back the updated array content
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
要打开的工作簿的“K:K”列必须按升序排序...
已编辑:
下一个版本无需对“K:K”列进行排序即可工作:
Sub Get_Last_Closing_Date()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim arr1() As Variant, arr2() As Variant
Dim dict As Object
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx", UpdateLinks:=False, ReadOnly:=True)
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
Set rng1 = ws1.Range("A3:K" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row) 'Main Range
Set rng2 = ws2.Range("A3:M" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row)
arr1 = rng1.Value2
arr2 = rng2.Value2
'place the unique last key in a dictionary:
Dim i As Long
Set dict = CreateObject("Scripting.dictionary")
For i = 1 To UBound(arr2)
If arr2(i, 13) = "Close" Then
If Not dict.Exists(arr2(i, 1)) Then
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11)) 'place the date from K:K, too
Else
If CDate(arr2(i, 11)) > CDate(dict(arr2(i, 1))(1)) Then 'change the item only in case of a more recent date:
dict(arr2(i, 1)) = Array(arr2(i, 2), arr2(i, 11))
End If
End If
End If
Next i
'Place the necessary data in its place:
For i = 1 To UBound(arr1)
If dict.Exists(arr1(i, 1)) Then
arr1(i, 11) = dict(arr1(i, 1))(0) 'extract first item array element
Else
arr1(i, 11) = "NA"
End If
Next i
rng1.Value2 = arr1 'drop back the updated array content
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
关于excel - 获取最近截止日期的相应值,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/75181219/