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

解決済みの質問

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

投稿日時 - 2018-10-11 10:56:23

QNo.9546493

困ってます

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

>実行しますと画像が消えてしまいます。
これで消えることはないでしょう
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

投稿日時 - 2018-10-11 19:34:15

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

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

回答(5)

ANo.5

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

投稿日時 - 2018-10-14 08:18:00

補足

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

投稿日時 - 2018-10-14 10:24:41

ANo.3

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

投稿日時 - 2018-10-11 18:57:51

補足

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

A1からA3の行は表題です。

画像はC列にあります。
1枚目はC4~W18
2枚目はC20からW34
3枚目はC36からW50
・・・・
となります。

よろしくお願いします。

投稿日時 - 2018-10-14 01:23:15

ANo.2

修正
標準モジュールに記述してください。
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

投稿日時 - 2018-10-11 16:46:21

ANo.1

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

投稿日時 - 2018-10-11 11:52:56

補足

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

投稿日時 - 2018-10-11 18:33:59

あなたにオススメの質問