VBA シートセルの高さで写真の大きさを変更する

質問

よろしくお願いします。

シートセルの高さで写真の大きさ（高さ）を変更する。

Excel 2010のシートの結合セルに貼り付けてある写真を
ユーザーフォームの、コマンドボタン(画像3枚_Click)(画像4枚_Click)で
3枚で1ページと、4枚で1ページに変更（セルの高さを変更する）したときに
貼り付けてある写真のサイズを
セルの高さに合わせて、縮小または拡大する（縦横比は無視）する。

Private Sub 画像3枚_Click()
Application.ScreenUpdating = False
Unload Me
Application.Visible = True
Sheets("写真").ResetAllPageBreaks
For i = 48 To 2000 Step 45
Sheets("写真").HPageBreaks.Add Before:=Cells(i, 1)
Next
Sheets("写真 ").Range("A1:A2000").RowHeight = 16.75
UserForm1.Show vbModeless
Application.ScreenUpdating = True
End Sub

Private Sub 画像4枚_Click()
Application.ScreenUpdating = False
Application.Visible = True
Sheets("写真").ResetAllPageBreaks
For j = 63 To 2000 Step 60
Sheets("写真").HPageBreaks.Add Before:=Cells(j, 1)
Next
Sheets("写真").Range("A1:A2000").RowHeight = 14.25
Unload Me
UserForm1.Show vbModeless
Application.ScreenUpdating = True
End Sub

回答No.4

watabe007 · ベストアンサー

>実行しますと画像が消えてしまいます。
これで消えることはないでしょう
Private Sub 画像3枚_Click()
・・・・・
　　Call Adjustsize(16.75 * 15)
　　Application.ScreenUpdating = True
End Sub
Private Sub 画像4枚_Click()
・・・・・
　　Call Adjustsize(14.25 * 15)
　　Application.ScreenUpdating = True
End Sub
標準モジュールに
Function Adjustsize(h As Single)
　　Dim myShap As Shape
　　For Each myShap In ActiveSheet.Shapes
　　　　If myShap.Type = 13 Then
　　　　　　With myShap
　　　　　　　　.LockAspectRatio = msoFalse
　　　　　　　　.Height = h
　　　　　　End With
　　　　End If
　　Next
End Function

回答No.5

watabe007

回答No.4で「セルの高さに合わせて縮小または拡大する」 達成しませんか?
>画像はＣ列にあります。
>1枚目はＣ4～Ｗ18
>2枚目はＣ20からＷ34
>3枚目はＣ36からＷ50
>For i = 48 To 2000 Step 45
何故3枚目の途中で改ページに?
Stepは１枚当たり15行+1 なので 16×3枚で48になるのでは?

補足

watabe007 様
すみません。
ご指摘の通りです。

回答No.3

watabe007

>実行しますと画像が消えてしまいます。
画像はA列の結合セル上に有ると仮定して処理を行っています。
実際は、どのセル上に有るのかわかりやすく示してください。

補足

watabe007 様
返事が遅くなりましてすみません。

Ａ1からＡ3の行は表題です。

画像はＣ列にあります。
1枚目はＣ4～Ｗ18
2枚目はＣ20からＷ34
3枚目はＣ36からＷ50
・・・・
となります。

よろしくお願いします。

回答No.2

watabe007

修正
標準モジュールに記述してください。
Function Adjustsize()
　　Dim myShap As Shape
　　For Each myShap In ActiveSheet.Shapes
　　　　If myShap.Type = 13 Then
　　　　　　With myShap
　　　　　　　　.LockAspectRatio = msoFalse
　　　　　　　　.Top = .TopLeftCell.MergeArea.Top
　　　　　　　　.Left = .TopLeftCell.MergeArea.Left
　　　　　　　　.Width = .TopLeftCell.MergeArea.Width
　　　　　　　　.Height = .TopLeftCell.MergeArea.Height
　　　　　　End With
　　　　End If
　　Next
End Function

回答No.1

watabe007

Private Sub 画像3枚_Click()
・・・・・
・・・・・
　　Call Adjustsize
　　Application.ScreenUpdating = True
End Sub
Private Sub 画像4枚_Click()
・・・・・
・・・・・
　　Call Adjustsize
　　Application.ScreenUpdating = True
End Sub
Function Adjustsize()
　　Dim myShap As Shape
　　For Each myShap In ActiveSheet.Shapes
　　　　If myShap.Type = 13 Then
　　　　　　With myShap
　　　　　　　　.LockAspectRatio = msoFalse
　　　　　　　　.Width = .TopLeftCell.MergeArea.Width
　　　　　　　　.Height = .TopLeftCell.MergeArea.Height
　　　　　　End With
　　　　End If
　　Next
End Function

補足

watabe007 さん
早速の回答ありがとうございます。
実行しますと画像が消えてしまいます。
よろしくご教示お願いします