Excel VBA質問箱 IV

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

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


36 / 75391 ←次へ | 前へ→

【81006】PCの移行に伴うVBAの不具合について
質問  beans E-MAIL  - 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

47 hits

【81006】PCの移行に伴うVBAの不具合について beans 19/7/8(月) 14:12 質問[未読]
【81017】Re:PCの移行に伴うVBAの不具合について よろずや 19/7/9(火) 13:45 発言[未読]

36 / 75391 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free