こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

マクロを実行すると画像がズレてしまいます

VBAで汎用のものを利用して以下のようなマクロを組んだのですが、画像を挿入すると少しずつずれていってしまいます。
原因が分かる人がいましたらご教授ください。
下のを見てもわかると思いますが、VBAについてはまったくの初心者です
よろしくお願いします。
またよろしければ1枚目でA3を指定すると2枚目もA3に重ねて貼ってしまうミスも訂正してくれると助かります。
Private Sub CommandButton1_Click()

  Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Dim ActCell As Range
Set ActCell = ActiveCell

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = 178.5
End With
Static a
Static p
a = a + 1
b = (a - 1) / 4
c = (a - 2) / 4
d = (a - 3) / 4
e = a / 4

If b = Int(b) Then
p = 58 * b + 3
ElseIf c = Int(c) Then
p = 58 * c + 16
ElseIf d = Int(d) Then
p = 58 * d + 29
ElseIf e = Int(e) Then
p = 58 * (e - 1) + 42
End If

' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
Cells(p, 1).Select

Set PIC = Nothing
Next i
End Sub

投稿日時 - 2011-03-03 02:26:17

QNo.6563777

すぐに回答ほしいです

質問者が選んだベストアンサー

Excelのバージョンは2007でしょうか?
もしそうなら[更新プログラムのチェック]を行って、プログラムのアップデイトをしてください。
以前は、Zoom100%以外の時に画像の貼り付け位置がずれるという不具合がありました。

念のためZoom制御を加えたコードです。

Private Sub CommandButton1_Click()
 Dim strFilter As String
 Dim Filenames As Variant
 Dim ActCell  As Range
 Dim i     As Long
 Dim x     As Long  '貼り付け先計算用
 Dim z     As Long  '現状Zoom記録

 '「ファイルを開く」ダイアログでファイル名を取得
 strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
 Filenames = Application.GetOpenFilename( _
       FileFilter:=strFilter, _
       Title:="図の挿入(複数選択可)", _
       MultiSelect:=True)
 If Not IsArray(Filenames) Then Exit Sub

 z = ActiveWindow.Zoom '■
 'ファイル名をソート
 Call BubbleSort_Str(Filenames, True, vbTextCompare)
 '■シート最終画像のTopLeftCell行を取得
 With ActiveSheet.Pictures
  'CommandButtonなどもカウントしてしまうので『> 1』適宜修正必要
  If .Count > 1 Then
   x = .Item(.Count).TopLeftCell.Row
  Else
   '無い場合は-10+13で次に3になる
   x = -10
  End If
 End With
 ActiveWindow.Zoom = 100
 'マクロ実行中の画面描写を停止
 Application.ScreenUpdating = False
 '順番に画像を挿入
 For i = LBound(Filenames) To UBound(Filenames)
  '■ActCellの13行下に次のActCell(貼り付け先)をセット
  If x Mod 58 = 42 Then
   x = x + 19
  Else
   x = x + 13
  End If
  Set ActCell = ActiveSheet.Cells(x, 1)
  With ActiveSheet.Pictures.Insert(Filenames(i))
   With .ShapeRange
    .LockAspectRatio = msoTrue '縦横比維持
    .Height = 178.5
   End With
   .Top = ActCell.Top      '■位置:ActCellの上側に重ねる
   .Left = ActCell.Left     '■位置:ActCellの左側に重ねる
   .Placement = xlMove     '移動するがサイズ変更しない
   .PrintObject = True     '印刷する
  End With
 Next i
 Set ActCell = Nothing
 Application.ScreenUpdating = True
 ActiveWindow.Zoom = z
End Sub

貼り付け開始はA3セルで、13行間隔で下へ貼り付ける、ただし4枚毎に19行間隔で貼り付ける、のが基本です。
要件が今一つ不明だったので、シートに画像があれば追加貼り付けするようにしてます。
常にA3セルから貼り付けるなら、既存画像を削除して実行するか、適宜コードを修正してください。

投稿日時 - 2011-03-03 20:59:36

お礼

>Excelのバージョンは2007でしょうか?
もしそうなら[更新プログラムのチェック]を行って、プログラムのアップデイトをしてください。
以前は、Zoom100%以外の時に画像の貼り付け位置がずれるという不具合がありました。

ありがとうございます!まさにこの症状でした

投稿日時 - 2011-03-03 22:42:58

ANo.2

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

>..少しずつずれていってしまいます。
というのは、13行間隔で貼り付けたいが、4枚に1枚は19行間隔になってしまう、
という意味ですか?

元々そのような内容のコードみたいですが、やりたい事は
『ActiveCellから13行間隔で下に貼り付けていく』
という内容でいいのでしょうか?

その場合、最初の貼り付け先を選択して以下コード実行です。

Private Sub CommandButton1_Click()
  Dim strFilter As String
  Dim Filenames As Variant
  Dim PIC    As Picture
  Dim i     As Long
  
  ' 「ファイルを開く」ダイアログでファイル名を取得
  strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
  Filenames = Application.GetOpenFilename( _
        FileFilter:=strFilter, _
        Title:="図の挿入(複数選択可)", _
        MultiSelect:=True)
  If Not IsArray(Filenames) Then Exit Sub
  ' ファイル名をソート
  Call BubbleSort_Str(Filenames, True, vbTextCompare)
  ' 貼り付け開始セルを選択(ActiveCellをActCellにセット)
  Dim ActCell As Range
  Set ActCell = ActiveCell
  ' マクロ実行中の画面描写を停止
  Application.ScreenUpdating = False
  ' 順番に画像を挿入
  For i = LBound(Filenames) To UBound(Filenames)
    Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))
    '-------------------------------------------------------------
    ' 画像の各種プロパティ変更
    '-------------------------------------------------------------
    With PIC
      .Top = ActCell.Top     ' ■位置:ActCellの上側に重ねる
      .Left = ActCell.Left    ' ■位置:ActCellの左側に重ねる
      .Placement = xlMove    ' 移動するがサイズ変更しない
      .PrintObject = True    ' 印刷する
    End With
    With PIC.ShapeRange
      .LockAspectRatio = msoTrue ' 縦横比維持
      ' 画像の高さをアクティブセルにあわせる
      ' 結合セルの場合でも対応
      .Height = 178.5
    End With
    '■現在のActCellの13行下に次のActCell(貼り付け先)をセット
    Set ActCell = ActiveSheet.Cells(ActCell.Row + 13, ActCell.Column)
    Set PIC = Nothing
  Next i
  Set ActCell = Nothing
  Application.ScreenUpdating = True
End Sub

変更のポイントは■の行です。

投稿日時 - 2011-03-03 12:58:25

補足

お礼に書き忘れたのでこちらに書いておきます
http://okwave.jp/qa/q4860324.html
個人的にこの方と同じ症状だと思います
この方は自己解決できたようですが、私にはできませんでした・・・

投稿日時 - 2011-03-03 18:34:44

お礼

お早い回答ありがとうございます

>..少しずつずれていってしまいます。
>というのは、13行間隔で貼り付けたいが、4枚に1枚は19行間隔になってしまう、
という意味ですか?

貼りたい位置はA3,A16,A29,A42まで行ったら次は
A61,A74,A87,A100と行くように設定しようと思ったので
Static a
Static p
a = a + 1
b = (a - 1) / 4
c = (a - 2) / 4
d = (a - 3) / 4
e = a / 4

If b = Int(b) Then
p = 58 * b + 3
ElseIf c = Int(c) Then
p = 58 * c + 16
ElseIf d = Int(d) Then
p = 58 * d + 29
ElseIf e = Int(e) Then
p = 58 * (e - 1) + 42
End If
でいいと思います(多分)

>画像がずれる
写真のように
■■■■■■■■■■■■
■               ■━━━━━━ここ揃えたい
■               ■ 
■    A29のがぞう    ■
■               ■
■               ■
■               ■
■■■■■■■■■■■■

■■■■■■■■■■■■
■               ■
■               ■━━━━━━ここ揃えたい  
■    A42のがぞう    ■
■               ■
■               ■
■               ■
■■■■■■■■■■■■
こんな感じで徐々に定位置から上方向にズレてしまうということです。
自分で新しいシートを作成して実行したところズレなかったのですが、友人から頼まれたシートでやるとズレてしまいます

投稿日時 - 2011-03-03 18:28:42

あなたにオススメの質問