
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

No.2ベストアンサー
- 回答日時:
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セルから貼り付けるなら、既存画像を削除して実行するか、適宜コードを修正してください。
>Excelのバージョンは2007でしょうか?
もしそうなら[更新プログラムのチェック]を行って、プログラムのアップデイトをしてください。
以前は、Zoom100%以外の時に画像の貼り付け位置がずれるという不具合がありました。
ありがとうございます!まさにこの症状でした
No.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
変更のポイントは■の行です。
この回答への補足
お礼に書き忘れたのでこちらに書いておきます
http://okwave.jp/qa/q4860324.html
個人的にこの方と同じ症状だと思います
この方は自己解決できたようですが、私にはできませんでした・・・
お早い回答ありがとうございます
>..少しずつずれていってしまいます。
>というのは、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のがぞう ■
■ ■
■ ■
■ ■
■■■■■■■■■■■■
こんな感じで徐々に定位置から上方向にズレてしまうということです。
自分で新しいシートを作成して実行したところズレなかったのですが、友人から頼まれたシートでやるとズレてしまいます
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
-
オートシェイプがずれる
Excel(エクセル)
-
セルに画像挿入すると、右セルに移動するにつれて画像位置がずれるので、ずれていかないようにしたい
Visual Basic(VBA)
-
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
-
4
エクセルVBA 画像を貼り付けるセル位置を指定する方法
Excel(エクセル)
-
5
Excel のバージョンによって、図形の位置がずれる
Excel(エクセル)
-
6
Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて
Excel(エクセル)
-
7
エクセル:マクロ「Application.CutCopyMode = False」って?
Excel(エクセル)
-
8
Pictures.Insertメソッド⇒Shapes.AddPictureメソッドに変更したいです。
Visual Basic(VBA)
-
9
VBAでセルを指定した画像のコピー&ペーストを繰り返したい
Excel(エクセル)
-
10
【VBA】写真の貼り付けコードがうまく機能しません。
Visual Basic(VBA)
-
11
エクセルに写真を挿入するマクロを組んでいます。
Visual Basic(VBA)
-
12
オートシェイプの位置がずれる件について教えてください
Visual Basic(VBA)
-
13
VBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)
Excel(エクセル)
-
14
エクセルvbaでの図形のカット(コピー)ペーストについて
Excel(エクセル)
-
15
エクセルVBAで縦向きの画像の挿入・回転
Excel(エクセル)
-
16
Excel vbaについての質問
Visual Basic(VBA)
-
17
VBAで写真を設定したフレームに挿入しようとしたが、Rotation=90の場合うまくいかない
Excel(エクセル)
-
18
エクセルマクロでシート内にある画像のみを選択する
Excel(エクセル)
-
19
VBAでブックを非表示で開いて処理して閉じる方法
Excel(エクセル)
-
20
Excel VBAでのWorksheet_Changeが動作しない原因
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
クリックすると文章が表示され...
-
EXCELで特定のセルに表示...
-
エクセル 数字をすべて○などの...
-
セルデータの一時保存
-
エクセルで独自のキーボードシ...
-
DRセルのリンクをCセルにハイパ...
-
マクロで未来?の日付を算出する
-
太字に設定されているセルの個...
-
Excel ハイパーリンクのURLを別...
-
エクセルでの特定位置のセル内...
-
VBA 見つからなかった時の処理
-
Excelの関数で時刻を固定する方法
-
セルの値が変ると自動でマクロ...
-
Excelでセルをクリックす...
-
セルの内容をテキストボックス...
-
エクセルで時間と連動して数値...
-
Excel内での検索結果をシート...
-
マクロを実行すると画像がズレ...
-
sheetsの保護されていないセル...
-
現在のセルの位置を返す関数は...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
EXCELで特定のセルに表示...
-
Excel内での検索結果をシート...
-
エクセル 数字をすべて○などの...
-
クリックすると文章が表示され...
-
Excelで、図形内の文字をセルに...
-
Excel ハイパーリンクのURLを別...
-
Excelでセルをクリックす...
-
太字に設定されているセルの個...
-
マクロを実行すると画像がズレ...
-
現在のセルの位置を返す関数は...
-
Excel:セルの値(文字列)を数...
-
Excel2007 色のカウント (VBA)
-
セルの内容をテキストボックス...
-
セルがクリックされた回数をカ...
-
エクセル 未入力セルがあると...
-
エクセルマクロ 赤色の文字を検...
-
選択したセル範囲に入っている...
-
アポストロフィーの一括挿入 ...
-
エクセルでPDFリンクを大量...
-
エクセルでセルをダブルクリッ...
おすすめ情報