Option Explicit
Private Sub 一键点击将对应备注填入目标单元格_Click()
Dim arr, brr, i, j, k, dic, t, m, cnt
Set dic = CreateObject("scripting.dictionary")
For i = 9 To 13
If j < Cells(Rows.Count, i).End(xlUp).Row Then
j = Cells(Rows.Count, i).End(xlUp).Row
End If
Next
arr = Range("i3:o" & j)
For i = 1 To UBound(arr, 1)
t = arr(i, 1) & "|": m = m + 1
If Len(arr(i, 1)) Then cnt = 1 Else cnt = 0
For j = 2 To 5
t = t & arr(i, j) & "|": arr(m, j) = arr(i, j)
If Len(arr(i, j)) Then cnt = cnt + 1
Next
If dic.exists(t) Then
m = m - 1
Else
dic(t) = arr(i, 6): arr(m, 7) = cnt
End If
Next
With [i3]
.Resize(Rows.Count - 2, UBound(arr, 2) - 1).ClearContents
.Resize(m, UBound(arr, 2) - 1) = arr
End With
For i = 1 To m - 1
For j = i + 1 To m
If arr(i, 7) < arr(j, 7) Then
For k = 1 To UBound(arr, 2)
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
End If
Next j, i
brr = Range("b3:f" & Cells(Rows.Count, "b").End(xlUp).Row)
For i = 1 To UBound(brr, 1)
For j = 1 To m
For k = 1 To 5
If Len(arr(j, k)) Then
If brr(i, k) <> arr(j, k) Then Exit For
End If
Next
If k = 6 Then brr(i, 1) = arr(j, 6): Exit For
Next
If j = m + 1 Then brr(i, 1) = "无对应数据"
Next
[g3].Resize(UBound(brr, 1)) = brr
End Sub |