質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.92%

【VBA】画像を張り付けた際の位置の誤差

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 232

j9y1316c

score 4

お世話になっています。

フォルダの画像をエクセルに張り付けるVBAを作ろうとしています。

画像間隔をセル間としてコードを書きましたが、誤差が積み重なり枚数が多くなるとずれが生じてしまいます。
これを解決したいと思い、以下のコードを追加してみましたがうまくいきません。
With Selection
.ShapeRange.Top = ActiveCell.Top
.ShapeRange.Left = ActiveCell.Left
.Height = ActiveCell.Height
End With

画像をセルにぴったりと合うような補正がしたいです。
ループをしながら定期的に、セルの上部と画像の上部を合わせる操作をしたいのですがどのようにすればよいのでしょうか。

もしくは、画像の挿入位置をすべてセルで指定すればいいのでしょうが、以下の操作をセル位置を使い指定する方法がわかりません。
i = i + 1
If i Mod 4 = 1 Then
lngTop = lngTop + e * 17
Else: lngTop = lngTop + e + d
End If

ちなみに挿入の横方向の位置は、写真を見ていただければわかりやすいと思うのですがセルの横辺に一致しないような場所に挿入したいのでポイントで指定しています。

超初心者です。
宜しくお願いします。![イメージ説明説明](a2cf2a57860f3c613b17903f40e51e96.png)](80ebc6d9e57389633ea282425dca967f.png)

Sub 画像貼り付け()


Dim lngTop As Long
Dim objFile As Object
Dim objFldr As FileSystemObject
Dim TheShape As Shape
Dim i As Integer
Dim d As Single
Dim e As Single
  Dim ws As Worksheet

d = Range("A16").Top - Range("A4").Top
e = Range("A17").Top - Range("A16").Top
lngTop = e * 3

'ポスト

  Set objFldr = CreateObject("Scripting.FileSystemObject")
  Worksheets("ポスト").Activate


  i = 1
       For Each objFile In objFldr.GetFolder(ThisWorkbook.Path & "\ポスト").Files

        ActiveSheet.Shapes.AddPicture _
                Filename:=objFile, _
                LinkToFile:=False, _
                SaveWithDocument:=True, _
                Left:=9.5, _
                Top:=lngTop, _
                Height:=d, _
                Width:=252.834

         With Selection


    .ShapeRange.Top = ActiveCell.Top
    .ShapeRange.Left = ActiveCell.Left

    .Height = ActiveCell.Height
    End With

     i = i + 1

          If i Mod 4 = 1 Then
             lngTop = lngTop + e * 17

          Else: lngTop = lngTop + e + d

          End If


    Next

End Sub



コード
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

0

https://teratail.com/questions/277517
これで解決したのではないですか?

コードを追加します。
X座標は適宜調整してください。

Sub 画像貼り付け()

    Dim objFile As Object
    Dim objFldr As FileSystemObject
    Dim TheShape As Shape
    Dim i As Integer
    Dim x, y As Integer
    Dim r As Integer
    Dim h As Integer

    Const Y_NUM = 4          ' 何枚の画像を1グループとするか
    Const Y_ROWS = 13        ' 1枚の画像とする行数(空行含む)

    Set objFldr = CreateObject("Scripting.FileSystemObject")

    i = 0
    For Each objFile In objFldr.GetFolder(ThisWorkbook.Path & "\picture").Files

        r = i * Y_ROWS + 1                      ' セル位置(列)を計算
        r = r + Int(i / Y_NUM)                  ' グループ間の空行を追加
        x = ActiveSheet.Cells(r, 1).Left        ' セルの座標(X)を取得
        y = ActiveSheet.Cells(r, 1).Top         ' セルの座標(Y)を取得
        h = ActiveSheet.Cells(r + Y_ROWS - 1, 1).Top - ActiveSheet.Cells(r, 1).Top  ' 画像の高さを計算

        ActiveSheet.Shapes.AddPicture _
            Filename:=objFile, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=x, _
            Top:=y, _
            Width:=252.834, _
            Height:=h

        i = i + 1
    Next

End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/07/16 14:44

    試してみました。
    画像間を枚数ごとに指定する以下のコードはどのようにしたらリンク先のコードに組み込めるでしょうか。
    試行錯誤してますがうまくいきません。
    頭が悪く申し訳ないですが、、よろしくお願いいたします。

    i = i + 1

    If i Mod 4 = 1 Then
    lngTop = lngTop + e * 17

    Else: lngTop = lngTop + e + d

    キャンセル

  • 2020/07/16 15:05

    前々回のコードを修正してみました。
    ご確認ください。

    キャンセル

  • 2020/07/16 17:46

    完成しました...!
    何から何までありがとうございます。
    とても勉強になりました。
    本当にありがとうございます。

    キャンセル

0

dとeを一度しか計算していませんが、行の状況によってずれてきます。
ループの中で都度計算してください。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/07/16 17:46

    そうなんですね...
    VBAは難しいです。
    もっと勉強します。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.92%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る