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

解決済みの質問

エクセル マクロ 写真貼り付け

エクセル マクロ 写真貼り付け
よろしくお願いします。
以前ここで、エクセルに写真を張り付けるマクロのコードが乗っていたので、それを使わせていただいていたのですが、PCを入れ替えてからうまく動作してくれません。どなたか修正個所を教えていただけると助かります。
OS ビスタ 
エクセル 2007

"data"シートに貼付する写真のあるフォルダのパス、写真ファイル名が張り付ける分だけ表記されていて、"picture"シートに"data"シートの指定した写真を張り付けていきます。
A4用紙に以前はB3セル辺りから写真を指定の大きさに張り付け、次のページに移動してB37セルB71セルB105セルと写真貼り付けをしてくれましたが、PC入れ替え後から写真が1ページ目のB3セルに重ねて張り付けられてしまいます。
以前のように各ページに1枚ずつ写真を指定の大きさに張り付けるにはどうしたらよいのでしょうか。
以前はOS XP  エクセル2003でした。
マクロに関しては素人です。どうかよろしくお願いします。

Sub MakeThumbnail()
Cells.Select
Selection.RowHeight = 22.5
Dim myDataCnt As Long
Dim myNo As Long
Dim i As Long
Dim myRow As Long
Dim myName As String

myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row
myNo = 1
myRow = 2

Worksheets("picture").Select
Do Until myNo > myDataCnt
myName = Worksheets("data").Cells(myNo, 1).Value

Cells(myRow, 2).Select
ActiveSheet.Pictures.Insert(myName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 200#

myRow = myRow + 12
myNo = myNo + 1
Loop

End Sub

投稿日時 - 2010-07-14 18:00:34

QNo.6038210

困ってます

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

>Cells.Select
>Selection.RowHeight = 22.5

>写真が下に向かって、ずれて張り付けされました。
>A4ぺーじに1枚ずつ貼り付けをしたかったのですが、
>myRow + 34  こんな感じでずれる量を調整してみました。
毎回、行高を設定する必要があるのかな?
毎回、pictureシートが新規で作成されるとか


>Application.ScreenUpdating = False
>  myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row
>  myRow = 2
>  Worksheets("picture").Select
  Cells.RowHeight = 22.5     '←1行追加してください。
>  myZoom = ActiveWindow.Zoom
>  ActiveWindow.Zoom = 100
>  For myNo = 1 To myDataCnt

投稿日時 - 2010-07-15 14:59:27

お礼

こんにちは。
さらに修正いただきありがとうございます。
行高の設定は最初からこうなっていたので、そのまま使っておりました。
いろいろ試してみましたが、やっぱりVBAは難しいです。
今後の勉強課題といたします。
ありがとうございました。

投稿日時 - 2010-07-16 12:19:50

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

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

回答(4)

ANo.3

>Application.ScreenUpdating = True
・・・・・・・・・
・・・・・・・・・
>Application.ScreenUpdating = False
間違えました、下記のように訂正してください。

Application.ScreenUpdating = False
・・・・・・・・・
・・・・・・・・・
Application.ScreenUpdating = True

投稿日時 - 2010-07-15 11:59:01

お礼

こんにちは。
早速のご教示ありがとうございます。
手直しまで入れていただき、大変お手数おかけしました。
本日仕事が休みのため、自宅のPCで動作確認してみました。
写真が下に向かって、ずれて張り付けされました。
A4ぺーじに1枚ずつ貼り付けをしたかったのですが、
myRow + 34  こんな感じでずれる量を調整してみました。
あとは仕事場で、調整しながらやってみます。
ありがとうございました。

投稿日時 - 2010-07-15 14:20:41

ANo.2

>写真が下に向かって、ずれて張り付けされました。
お試しください
Sub MakeThumbnail()
  Dim myDataCnt As Long
  Dim myNo As Long
  Dim myRow As Long
  Dim myName As String
  Dim myZoom As Single

  Application.ScreenUpdating = True
  myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row
  myRow = 2
  Worksheets("picture").Select
  myZoom = ActiveWindow.Zoom
  ActiveWindow.Zoom = 100
  For myNo = 1 To myDataCnt
    myName = Worksheets("data").Cells(myNo, 1).Value
    With ActiveSheet.Pictures.Insert(myName)
      .ShapeRange.LockAspectRatio = msoTrue
      .ShapeRange.Width = 200#
      .Left = Cells(myRow, 2).Left
      .Top = Cells(myRow, 2).Top
    End With
    myRow = myRow + 12
  Next
  ActiveWindow.Zoom = myZoom
  Application.ScreenUpdating = False
End Sub

投稿日時 - 2010-07-15 11:52:53

ANo.1

ちょと無駄なところもあるようですが、それは置いといて、
下記■の間の2行を追加すると動作すると思いますが。



------------------------
ActiveSheet.Pictures.Insert(myName).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = 200#

'■
Selection.ShapeRange.Top = Cells(myRow, 2).Top
Selection.ShapeRange.Left = Cells(myRow, 2).Left
'■

myRow = myRow + 12
myNo = myNo + 1
Loop
--------------------------------

以上です。
 

投稿日時 - 2010-07-14 20:50:56

お礼

こんにちは。
早速のご教示ありがとうございます。
本日仕事が休みのため、自宅のPCで動作確認してみました。
写真が下に向かって、ずれて張り付けされました。
後は何行ずらすか、試行錯誤しながらやってみます。
ありがとうございました。

投稿日時 - 2010-07-15 10:14:22

あなたにオススメの質問