请教VBA大神帮忙，谢谢！

笨鸟飞不高

请教VBA大神帮忙，谢谢！.rar (10.24 KB, 下载次数: 52)

2018-7-28 14:36 上传

点击文件名下载附件

jiminyanyan

看不懂，要干什么。。。

笨鸟飞不高

jiminyanyan 发表于 2018-7-28 14:38
看不懂，要干什么。。。

在E7到S7，E12到S12单元格中填上数字对应的图标，不用手工一个一个去复制 粘贴 ，请问VBA能解决吗？谢谢！

一把小刀闯天下

笨鸟飞不高 发表于 2018-7-28 14:58
在E7到S7，E12到S12单元格中填上数字对应的图标，不用手工一个一个去复制 粘贴 ，请问VBA能解决吗？谢谢 ...

Option Explicit

Sub test()
  Dim shp, i, j, flag As Boolean
  ReDim shapename(1 To 4)
  Sheets("一车间").Activate
  For Each shp In ActiveSheet.Shapes
    flag = True
    With shp
      If .Top > Rows(17).Top And .Top < Rows(18).Top And .Left < _
        Columns(2).Left Then shapename(1) = .Name: flag = False
      If .Top > Rows(17).Top And .Top < Rows(18).Top And .Left > _
        Columns(10).Left Then shapename(2) = .Name: flag = False
      If .Top > Rows(18).Top And .Top < Rows(19).Top And .Left < _
        Columns(2).Left Then shapename(3) = .Name: flag = False
      If .Top > Rows(18).Top And .Top < Rows(19).Top And .Left > _
        Columns(10).Left Then shapename(4) = .Name: flag = False
      If flag Then .Delete
    End With
  Next
  For i = 6 To 11 Step 5
    For j = 5 To 19
      If Cells(i, j) > 0 And Cells(i, j) < 5 Then
        ActiveSheet.Shapes.Range(Array(shapename(Cells(i, j)))).Select
        Selection.Copy
        Cells(i + 1, j).Select
        ActiveSheet.Paste
        Selection.Top = Cells(i + 1, j).Top + (Cells(i + 2, j).Top - _
          Cells(i + 1, j).Top) / 2 - Selection.Height / 2
        Selection.Left = Cells(i, j).Left + (Cells(i, j + 1).Left - _
          Cells(i, j).Left) / 2 - Selection.Width / 2
      End If
  Next j, i
End Sub