| |
OS Windows7 excel2013のPCからWindows10 excel2019のPC へ移行したところ、
これまで問題なく動いていた下記のマクロが、
（Rectangleクラスのcopyメソッドが失敗しました）として、完了できなくなってしまいました。
狙った行の抽出をするところまでは、動いているようなのですが、抽出された行にオートシェイプで作成した図形を張り付ける、赤色の下線を引くといった動作ができておりません。
エラーの際にデバッグを選択すると、下記Sub連続用4() 内のselection copyというところが黄色くマークアップされていました。
どのようにすればエラーを回避し、動作を完了できますでしょうか？
お助けいただけましたら幸いです。
Sub 連続用5()
Sheets("連続用").Select
Range("Y5:AC3000").Select
Selection.ClearContents
Range("A1").Select
End Sub
Sub 連続用2()
Sheets("連続用").Select
Application.ScreenUpdating = False
Dim meibo As Worksheet
Set meibo = Worksheets("連続用")
ro = 5
While meibo.Cells(ro, 1) <> ""
Range("Y4:AC4").Select
Selection.Copy
Cells(ro, 25).Select
ActiveSheet.Paste
ro = ro + 1
Wend
Application.ScreenUpdating = True
End Sub
Sub 連続用3()
Sheets("連続用").Select
Application.ScreenUpdating = False
Rows("5:3000").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("AC5"), Order1:=xlAscending, Key2:=Range("D5") _
, Order2:=xlAscending, Key3:=Range("E5"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal, DataOption3:=xlSortNormal
Range("A1").Select
End Sub
Sub 連続用4()
Sheets("連続用").Select
Application.ScreenUpdating = False
Dim meibo As Worksheet
Set meibo = Worksheets("連続用")
ro = 5
p = 6
While meibo.Cells(ro, 1) <> ""
If (Cells(ro, 29) = Cells(p, 29)) = True Then
If (Cells(ro, 4) = Cells(p, 4)) = True Then
If ((Cells(ro, 6) + Cells(2, 29)) > Cells(p, 5)) = True Then
Range(Cells(ro, 5), Cells(p, 6)).Interior.ColorIndex = 35
If (Cells(ro, 21) = Cells(p, 21)) = True Then
If (Cells(ro, 5) <> Cells(p, 5)) = True Then
If (Cells(ro, 6) <> Cells(p, 6)) = True Then
ActiveSheet.Shapes("AutoShape 18").Select
Selection.Copy
Cells(ro, 1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementTop 5.25
Selection.ShapeRange.IncrementLeft 2.25
End If
End If
End If
If ((Cells(ro, 35) + Cells(p, 35)) - (Cells(ro, 34) + Cells(p, 34))) <= ((Cells(ro, 16) + Cells(p, 16)) - Cells(2, 30)) = True Then
ActiveSheet.Shapes("AutoShape 18").Select
Selection.Copy
Cells(ro, 16).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementTop 5.25
Selection.ShapeRange.IncrementLeft 2.25
End If
Cells(ro, 33).Select
ActiveCell.FormulaR1C1 = "1"
Cells(p, 33).Select
ActiveCell.FormulaR1C1 = "1"
Range(Cells(ro, 1), Cells(p, 23)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End If
End If
End If
ro = ro + 1
p = ro + 1
Wend
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 19/7/8(月) 14:12 -
