|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim mypath$, myname$
- Dim wb As Workbook
- Dim ws As Worksheet
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- mypath = ThisWorkbook.Path & ""
- myname = "表1.xlsx"
- If Dir(mypath & myname) = "" Then
- MsgBox "表1.xlsx不存在!"
- Exit Sub
- End If
- Set wb = GetObject(mypath & myname)
- With wb
- For Each ws In .Worksheets
- With ws
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- For k = 1 To r
- If Right(.Cells(k, 1), 4) = "月份考试" Then
- arr = .Cells(k, 1).CurrentRegion
- For i = 4 To UBound(arr)
- For j = 2 To UBound(arr, 2)
- xm = arr(i, 1) & "+" & arr(2, j)
- d(xm) = arr(i, j)
- Next
- Next
- End If
- Next
- End With
- Next
- .Close False
- End With
- With Worksheets("sheet1")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- For k = 1 To r
- If .Cells(k, 1) = "抽查考试情况表" Then
- arr = .Cells(k, 1).CurrentRegion
- For i = 4 To UBound(arr)
- For j = 2 To UBound(arr, 2)
- xm = arr(i, 1) & "+" & arr(2, j)
- If d.exists(xm) Then
- arr(i, j) = d(xm)
- End If
- Next
- Next
- .Cells(k, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
- End If
- Next
- End With
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|