|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub qs()
- Dim wb As Workbook, xb As Workbook, p As String, arr, brr, sht As Worksheet, dic, crr, drr
- Set dic = CreateObject("scripting.dictionary")
- Set wb = ThisWorkbook
- p = wb.Path & ""
- Set xb = Workbooks.Open(p & "数据表.xls", 0)
- For Each sht In xb.Worksheets
- dic.RemoveAll
- arr = xb.Sheets(sht.Name).Range("c2").Resize(1, 7).Value
- brr = xb.Sheets(sht.Name).Range("c23").Resize(1, 7).Value
- For i = 1 To UBound(brr, 2)
- If Not dic.exists(brr(1, i)) Then
- dic(arr(1, i)) = brr(1, i)
- End If
- Next
- crr = wb.Sheets(sht.Name).Range("c2").Resize(1, 7).Value
- ReDim drr(1 To 1, 1 To UBound(crr, 2))
- For i = 1 To UBound(crr, 2)
- drr(1, i) = dic(crr(1, i))
- Next
- wb.Sheets(sht.Name).Range("c28").Resize(1, 7) = drr
- Next
- xb.Close (0)
- Set wb = Nothing: Set xb = Nothing
- Set sht = Nothing: Set dic = Nothing
- MsgBox "完成!"
- End Sub
复制代码 |
|