スキルアップ・問題解決なら、モーグにおまかせ！

sheet間でshapeのコピーをしますが、微妙にずれてしまいます。
 
Sub CopyShapes(srcSht As Worksheet, dstSht As Worksheet)
  'コピー元シートの図形をすべてコピーし、コピー先に貼り付ける
   
  Dim shp As shape
  Dim topY As Double
  Dim leftX As Double
  Dim shapeHeight As Double
  Dim shapeWidth As Double
   
  Dim i As Long
  For i = 1 To srcSht.Shapes.Count
    topY = srcSht.Shapes(i).Top
    leftX = srcSht.Shapes(i).Left
    shapeHeight = srcSht.Shapes(i).Height
    shapeWidth = srcSht.Shapes(i).Width
     
    srcSht.Activate
    srcSht.Shapes(i).Copy
    dstSht.Activate
    dstSht.Paste
     
    With dstSht.Shapes(dstSht.Shapes.Count)
      .Top = topY
      .Left = leftX
      .Height = shapeHeight
      .Width = shapeWidth
    End With
  Next i
 
  Set shp = Nothing
 
End Sub
改善する方法はないでしょうか。

    dstSht.Paste
     
で、下記エラーが発生します。
ErrCD:1004　Pasteメソッドは失敗しました。:_Worksheetオブジェクト
 
こちらについても、ご教示いただけますと幸いです。

(1)
A1セルの左上隅を原点とする位置でみると、
二つのシートでそれぞれの図形どうしは同じはずです。
 
もし、貼り付け先のセルとの関係で位置がズレているとか言われているなら、
基準が違うのでは、としか言えません。
つまり、もし二つのシートの列幅が、少しでも違っていたりすれば、違う風に見えますよ。
そういうことでなければ、Top,Left,Width,Heightがどう違うのか示されると良いと思います。
 
(2)
エラーの件は、shapeオブジェクトの中には、通常の図形だけでなく、
入力規則やメモなども含みます。
もしそれらがあれば、その方法ではコピーできませんのでエラーになりますね。
 
折角shp変数を宣言しているんですから、

    For i = 1 To srcSht.Shapes.Count
        Set shp = srcSht.Shapes(i)      ' 挿入
        .....

simple　様
 
お世話になっております。
ご連絡誠にありがとうございます。
 
エラーになる対象のshapeは、barcodecontrolであることがわかりました。
どのように対処したらよろしいでしょうか。

そのコントロールのTypeはそちらでわかったのでしょうから、（以下で そのTpe　と書いています）
 

   For i = 1 To srcSht.Shapes.Count
        Set shp = srcSht.Shapes(i)      
        If shp.Type <>   そのType   Then
               '処理
        End If
        

ありがとうございます。
 
現状の問題点としてコピー自体が出来ずにエラーになってしまいます。
barcodectrlをうまくコピーする方法は無いでしょうか。
よろしくお願い申し上げます。

(1)まず図形のズレについての当方のコメントへの回答をお願いします。
(2)情報を小出しにせずに、全体を説明してもらえますか？
   シートには何があって、コピーしたいのは何ですか？
   色々な種類があるなら、予め説明してもらえませんか？
(3)また、逆にシート自体をコピーする方法は採れないのですか？
   図形を修正するよりも、文字や値を修正するほうが確実ではないですか？
(4)
・バーコードコントロールは一旦除外して、
・以下のような方法で別途バーコードコントロールだけをコピーしてみてはどうですか？

Sub test2()
    Dim v
    dim shp As Shape
    For Each v In ActiveSheet.OLEObjects
        v.Copy
        Set shp = v.ShapeRange(1)
        ' こうすればshp はshapeオブジェクトなので、
        ' 既存の方法で位置を取得して、
        ・他シートに貼り付けたあとで、位置を調整すればどうでしょう。
    Next
End Sub

ありがとうございます。
 
シートについては、下記コードで対応しております。
ずれは発生しないのではないかと考えます。
    Dim myPSA As PageSetup
    Dim myPSB As PageSetup
     
    Set myPSA = ThisWorkbook.Sheets("�B-1出庫明細書").PageSetup
    Set myPSB = wbNew.Sheets("Sheet1").PageSetup
     
    Application.PrintCommunication = False
    With myPSB
        .PrintTitleRows = myPSA.PrintTitleRows 'タイトル行
        .PrintArea = myPSA.PrintArea '印刷範囲
        .LeftHeader = myPSA.LeftHeader 'ヘッダー
        .CenterHeader = myPSA.CenterHeader
        .RightHeader = myPSA.RightHeader
        .LeftFooter = myPSA.LeftFooter 'フッター
        .CenterFooter = myPSA.CenterFooter
        .RightFooter = myPSA.RightFooter
        .LeftMargin = myPSA.LeftMargin '余白
        .RightMargin = myPSA.RightMargin
        .TopMargin = myPSA.TopMargin
        .BottomMargin = myPSA.BottomMargin
        .HeaderMargin = myPSA.HeaderMargin
        .FooterMargin = myPSA.FooterMargin
        .PrintHeadings = myPSA.PrintHeadings '行列番号の印刷
        .PrintGridlines = myPSA.PrintGridlines '枠線の印刷
        .PrintComments = myPSA.PrintComments 'コメントの印刷
        .CenterHorizontally = myPSA.CenterHorizontally '水平中央設定
        .CenterVertically = myPSA.CenterVertically '垂直中央設定
        .Orientation = myPSA.Orientation '印刷向き
        .Draft = myPSA.Draft '簡易印刷
        .PaperSize = myPSA.PaperSize '用紙サイズ
        .FirstPageNumber = myPSA.FirstPageNumber '先頭ページ番号
        .Order = myPSA.Order 'ページ番号付けの方向
        '.BlackAndWhite = myPSA.BlackAndWhite '白黒印刷
        .BlackAndWhite = False '白黒印刷
         
        On Error Resume Next
        .Zoom = False ' ズーム倍率を無効化（これがないとFitToPagesが効かない）
        .FitToPagesWide = 1 ' 横方向を1ページに収める
        .FitToPagesTall = False ' 縦方向は制限しない（複数ページでもOK）
        On Error GoTo 0
         
        .PrintErrors = myPSA.PrintErrors 'エラーセルの印刷表記方針
    End With
    Application.PrintCommunication = True
 
 
よろしくお願い申し上げます。
 

印刷設定のコードで何をいいたいのか理解できません。すいません。
 
そもそもですが、「微妙にずれる」というのは何をもとに、何を根拠にそう言われているのか
説明が足りていないと思います。
あなたは画面なりが見えているから当たり前と思っても、他人にはそちらの画面は見えません。
もっとしっかりした説明が必要だと思います。
# 外出中なので返事はまた遅くなります。

サイズに関して
 

引用:
sheet間でshapeのコピーをしますが、微妙にずれてしまいます。

    Set myPSA = ThisWorkbook.Sheets("�B-1出庫明細書").PageSetup
    Set myPSB = wbNew.Sheets("Sheet1").PageSetup

        .Zoom = False ' ズーム倍率を無効化（これがないとFitToPagesが効かない）
        .FitToPagesWide = 1 ' 横方向を1ページに収める
        .FitToPagesTall = False ' 縦方向は制限しない（複数ページでもOK）

お世話になっております。
ありがとうございます。
 
バーコード部分は下記のように対応しました。
Sub BarCodeCtrlCopy2(srcSheet As Worksheet, dstSheet As Worksheet)
    Dim srcObj As OLEObject, newObj As OLEObject
 
 
    ' BarcodeControl の名前（例: "Barcode1"）を指定
    Set srcObj = srcSheet.OLEObjects("BarCodeCtrl2")
 
    ' Sheet2 に新しい BarcodeControl を追加
    Set newObj = dstSheet.OLEObjects.Add(ClassType:=srcObj.progID, _
                                         Link:=False, _
                                         DisplayAsIcon:=False, _
                                         Left:=srcObj.Left, _
                                         Top:=srcObj.Top, _
                                         Width:=srcObj.Width, _
                                         Height:=srcObj.Height)
 
    With newObj.Object
        .Style = 6
        .Validation = 1 'データの確認
        '.Weight = 3
        '.Orientation = 0
         
    End With
    With newObj
        .Top = srcObj.Top
        .Left = srcObj.Left
        .Width = srcObj.Width
        .Height = srcObj.Height
    End With
     
    ' 必要に応じてプロパティをコピー（例: Value や Caption など）
    On Error Resume Next
    newObj.Object.Value = srcObj.Object.Value
    newObj.Object.Caption = srcObj.Object.Caption
    On Error GoTo 0
 
End Sub
 
 

印刷のズレの件ですが、コピー元とコピー先のシートは全く同じ形式のシートなんですか？
列幅など同一ですか？
印刷範囲のセル範囲の大きさ（Width等）が微妙に異なっていると、
原点からの位置が同一でも、異なる縮小率になるので、印刷されたときの図形位置はズレますよね。
そうしたことについての言明がなく、印刷設定だけ合わせましただけでは、原因解明にならないのでは？
ということで
>印刷設定のコードで何をいいたいのか理解できません。
と申し上げました。
 
両方のシートを全く同一にする意味からは、
シートそのものをまるまるコピーして、図形以外の要素をあとから貼り付けるようにする方法は
とれないのですか？
 
いずれにしても印刷が意図通りにいかないことはよくあるらしいので、求めている精度がいかほどか
不明ですが、場合によってはExcel以外の選択肢も考えたほうがよいかもしれません。

ありがとうございます。
検討いたします。