|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
按AB列都 一致为条件,代码放例子表1里面去:
- Sub tp()
- Dim wb As Workbook, sh As Worksheet, spr, arr, c
- Dim r, i, j, k, cel As Range
- Application.ScreenUpdating = False
- Call delshp
- Set wb = GetObject(ThisWorkbook.Path & "\例子.xlsx")
- With wb.Sheets("Sheet1")
- c = .Shapes.Count
- If c > 0 Then
- ReDim spr(1 To c, 1 To 2)
- For i = 1 To c
- spr(i, 1) = .Shapes(i).TopLeftCell.Offset(0, -2).Value & "|" & .Shapes(i).TopLeftCell.Offset(0, -1).Value
- Set spr(i, 2) = .Shapes(i)
- Next
- End If
- End With
- With Sheets("Sheet1")
- .Activate
- r = .[A65536].End(xlUp).Row
- arr = .Range("A1:B" & r)
- For j = 2 To UBound(arr)
- For k = 1 To UBound(spr)
- If arr(j, 1) & "|" & arr(j, 2) = spr(k, 1) Then
- Set cel = .Range("C" & j)
- spr(k, 2).Copy
- cel.Select
- ActiveSheet.Paste
- With Selection
- .Top = cel.Top + 2
- .Left = cel.Left + 2
- End With
- End If
- Next
- Next
- End With
- MsgBox "OK!"
- wb.Close False
- Set wb = Nothing
- Erase spr, arr
- Application.ScreenUpdating = True
- End Sub
- Sub delshp()
- Dim shp
- On Error Resume Next
- For Each shp In ActiveSheet.Shapes
- shp.Delete
- Next
- End Sub
复制代码 |
|