如题，
思路
循环D列数据
循环K列数据
将abs(D-K)的值存入一个数组
Next K
设计一个单独的函数，完成如下功能：返回最小绝对值对应的数值所在的行数
根据函数返回的行和已知的列，定位具体单元格，并将其存储在一个数组中
Next D
一次性将该数组写入到单元格
代码
Sub t() ' 主过程 Dim x!, y!, r1!, r2! Dim arr1, arr2, temp_arr, conp_return, result_arr, result$ ' arr1 数组，一次性写入D列 ' arr2 数组，一次性写入K列数据 ' temp_arr 数组，存储D列 - K列每一个数的绝对值 ' conp_return 数组，接收conparison函数返回的数组 ' result_arr 数组，依次存储D列每一个数对应的结果 ' result 字符串，临时存储G列对应的值 r1 = [d2].End(xlDown).Row r2 = [k2].End(xlDown).Row arr1 = Range("d2:d" & r1) arr2 = Range("k2:k" & r2) ReDim result_arr(1 To r1) For x = 2 To r1 ReDim temp_arr(1 To r2) For y = 2 To r2 temp_arr(y - 1) = Abs(arr1(x - 1, 1) - arr2(y - 1, 1)) Next y conp_return = conparison(temp_arr) result = "" For y = 1 To UBound(conp_return) - 1 result = Cells(conp_return(y), "g") & "," & result Next y result_arr(x - 1) = VBA.Left(result, Len(result) - 1) Erase temp_arr Next x [e2].Resize(r1) = Application.Transpose(result_arr) End Sub Function conparison(arr) ' 返回最小绝对值对应的数所在行，考虑最小绝对值有可能不止一个，所以最好返回一个数组 Dim min_value As Double, i!, result_arr, element ReDim result_arr(1 To 1) min_value = Application.Min(arr) i = 1 For element = 1 To UBound(arr) If arr(element) = min_value Then result_arr(i) = element 1 ' 最小绝对值对应的数所在行 = 数组中的位置 1 i = i 1 ReDim Preserve result_arr(1 To i) End If Next element conparison = result_arr End Function
效果
