Sub cdsr() Dim Wb As Workbook Dim ws As Worksheet Dim arr, brr, i&, j& Dim Temp As String Temp = ThisWorkbook.Path & "\汇总数据表.xlsx" Set Wb = GetObject(Temp) arr = Wb.Sheets(1).Range("A1").CurrentRegion For Each ws In Sheets brr = ws.[a1].CurrentRegion For i = 2 To UBound(brr) For j = 2 To UBound(arr) If brr(i, 1) = arr(j, 1) Then brr(i, 2) = arr(j, 2) End If Next Next ws.[a1].Resize(UBound(brr), 2) = brr Erase brr Next Wb.Close False Set Wb = Nothing End Sub