Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1379 / 76734

←次へ　｜　前へ→


	【81006】PCの移行に伴うVBAの不具合について

beans

- 19/7/8(月) 14:12 -


	引用なし

	パスワード

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

5 hits

▼

【81006】PCの移行に伴うVBAの不具合について beans 19/7/8(月) 14:12