Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3537 / 13644 ツリー ←次へ | 前へ→

【61554】画像の右上のセルに保存する画像名を置く ai 09/5/17(日) 19:16 質問[未読]
【61555】Re:画像の右上のセルに保存する画像名を置く かみちゃん 09/5/17(日) 19:40 発言[未読]
【61556】Re:画像の右上のセルに保存する画像名を置く ai 09/5/17(日) 20:04 発言[未読]
【61557】Re:画像の右上のセルに保存する画像名を置く かみちゃん 09/5/17(日) 20:58 発言[未読]
【61558】Re:画像の右上のセルに保存する画像名を置く ai 09/5/17(日) 21:19 発言[未読]
【61559】Re:画像の右上のセルに保存する画像名を置く かみちゃん 09/5/17(日) 21:35 発言[未読]
【61560】Re:画像の右上のセルに保存する画像名を置く ai 09/5/17(日) 21:40 お礼[未読]

【61554】画像の右上のセルに保存する画像名を置く
質問  ai  - 09/5/17(日) 19:16 -

引用なし
パスワード
   あるブックの1つのシート内に複数の画像が規則的に並んでいます。
画像の3行上には画像についてのNoや画像の名前があり、画像の2行上には「遠景」か「近景」のどちらかが書かれています。
したい操作というのが、画像の右上のセルに、画像名と_と遠近かをまとめて配置したいんです。
手打ちだと画像右上のセルに、=E2&"_"&B3  (E2に画像名があり、B3に遠近のどちらかが入っています。)
というふうになりますが膨大な量なのでマクロで行いたいのです。

1つの行の画像が端まで終わると、2つ目の行の画像の上には遠近の項目しか書かれていなく、3つ目の行へいくと、名前や遠近が書かれていて、4つ目の行はまた遠近のみの項目のデータしかないです。

考えたのは
まず、画像の右上のセルを探し、そこに画像名と「_」と遠近を入れるということなのですが、コードがなかなかなもので。。。(画像名が飛び飛びに入っているので、画像名が入っていないところは上にさかのぼって参照したい)


どうかお知恵を貸してください。

【61555】Re:画像の右上のセルに保存する画像名を...
発言  かみちゃん E-MAIL  - 09/5/17(日) 19:40 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> 画像の右上のセルに、画像名と_と遠近かをまとめて配置したい

画像の右上のセル位置を取得したいということであれば、以下のような感じでできると思います。

Sub Sample()
 Dim rngTopRightCell As Range
 With ActiveSheet.Shapes("Picture 1")
  Set rngTopRightCell = .TopLeftCell.Offset(, .BottomRightCell.Column - .TopLeftCell.Column)
  MsgBox "画像 " & .Name & " の右上のセルは " & rngTopRightCell.Address
 End With
End Sub

【61556】Re:画像の右上のセルに保存する画像名を...
発言  ai  - 09/5/17(日) 20:04 -

引用なし
パスワード
   こんにちわ。早速のアドバイスありがとうございます。


>Sub Sample()
> Dim rngTopRightCell As Range
> With ActiveSheet.Shapes("Picture 1")
>  Set rngTopRightCell = .TopLeftCell.Offset(, .BottomRightCell.Column - .TopLeftCell.Column)
>  MsgBox "画像 " & .Name & " の右上のセルは " & rngTopRightCell.Address
> End With
>End Sub

やってみたんですが、3行目のWithの行がエラーになってしまいました。。。
画像をオブジェクトとして扱わないといけないのでしょうか??

【61557】Re:画像の右上のセルに保存する画像名を...
発言  かみちゃん  - 09/5/17(日) 20:58 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> 3行目のWithの行がエラーになってしまいました。。。
> 画像をオブジェクトとして扱わないといけないのでしょうか??

そうですね。

以下のコードは、アクティブシートのすべての画像の名前と右上のセルの位置を表示します。

Sub Sample2()
 Dim shp As Shape
 Dim rngTopRightCell As Range
 
 For Each shp In ActiveSheet.Shapes
  If shp.Type = msoPicture Then
   With shp
    Set rngTopRightCell = .TopLeftCell.Offset(, .BottomRightCell.Column - .TopLeftCell.Column)
    MsgBox "画像 " & .Name & " の右上のセルは " & rngTopRightCell.Address
   End With
  End If
 Next
End Sub

【61558】Re:画像の右上のセルに保存する画像名を...
発言  ai  - 09/5/17(日) 21:19 -

引用なし
パスワード
   少し題名と変わるのですが、
以前教えて頂いたコードを編集して以下のようにしてみました。
すると、半分は上手く保存できたのですが、
項目で「画像の名前」が飛ばされている箇所は保存できませんでした。

なので、画像名が空白セルであれば10行上にある項目を参照といったふうにしたいのですが、

If 画像名 = "" Then
  画像名 = AcSh.Range(図形右上セル).Offset(-13, -4).Value

を加えて実行してみたのですが上手くいきませんでした。。。


Sub 画像Jpeg保存()
Dim AcSh As Worksheet, NwBk As Workbook
Dim Obj As Object, Crt As Chart, CrtNm As String
Dim Rgh As Double, Rgw As Double
Dim LT As String, BR As String, 図形右上セル As String
Dim 画像名 As String
Dim 遠近 As String

'現在のシートを省略して使う用にセット
Set AcSh = ActiveSheet
Set NwBk = Workbooks.Add
Set Crt = NwBk.Sheets(1).ChartObjects.Add(0, 0, Rgw, Rgh).Chart
CrtNm = Mid(Crt.Name, InStr(1, Crt.Name, " ") + 1)

For Each Obj In AcSh.DrawingObjects.ShapeRange
  'グループ化については無視。
  If Obj.Type = msoPicture Then

   '左上
   LT = Obj.TopLeftCell.Address
   '右下
   BR = Obj.BottomRightCell.Address
   図形右上セル = AcSh.Range(LT, BR).Rows(1).Cells(AcSh.Range(LT, BR).Rows(1).Cells.Count).Address
   If AcSh.Range(図形右上セル).Row <> 1 Then
     画像名 = AcSh.Range(図形右上セル).Offset(-3, -4).Value
     遠近 = AcSh.Range(図形右上セル).Offset(-2, -7).Value
   Else
     画像名 = AcSh.Range(図形右上セル).Offset(, 1).Value
   End If

   Rgh = Obj.Height - 0.5
   Rgw = Obj.Width - 0.5
   NwBk.Sheets(1).ChartObjects(CrtNm).Height = Rgh
   NwBk.Sheets(1).ChartObjects(CrtNm).Width = Rgw
   Obj.CopyPicture Format:=xlBitmap

   With Crt
     .Paste
     .ChartArea.Border.LineStyle = 0

     NwBk.Sheets(1).ChartObjects(CrtNm).Chart.Shapes(1).IncrementLeft -4
     NwBk.Sheets(1).ChartObjects(CrtNm).Chart.Shapes(1).IncrementTop -4
  
     .Export CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "R-" & 画像名 & "_" & 遠近 & ".jpg"
     DoEvents
   End With
   NwBk.Sheets(1).ChartObjects(CrtNm).Chart.Shapes(1).Delete
  End If
Next
NwBk.Sheets(1).ChartObjects(CrtNm).Delete
NwBk.Close (False)
Set AcSh = Nothing
Set NwBk = Nothing
Set Crt = Nothing
End Sub

【61559】Re:画像の右上のセルに保存する画像名を...
発言  かみちゃん  - 09/5/17(日) 21:35 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>以前教えて頂いたコードを編集して以下のようにしてみました。
>すると、半分は上手く保存できたのですが、
>項目で「画像の名前」が飛ばされている箇所は保存できませんでした。
>
>なので、画像名が空白セルであれば10行上にある項目を参照といったふうにしたいのですが、
>
>If 画像名 = "" Then
>  画像名 = AcSh.Range(図形右上セル).Offset(-13, -4).Value
>
>を加えて実行してみたのですが上手くいきませんでした。。。

どううまくいかないのでしょうか?
そのコードでは、10行上ではなく、13行上になっていますが、いかがでしょうか?

   '左上
   LT = Obj.TopLeftCell.Address
   '右下
   BR = Obj.BottomRightCell.Address
   図形右上セル = AcSh.Range(LT, BR).Rows(1).Cells(AcSh.Range(LT, BR).Rows(1).Cells.Count).Address
   If AcSh.Range(図形右上セル).Row <> 1 Then
    画像名 = AcSh.Range(図形右上セル).Offset(-3, -4).Value
    遠近 = AcSh.Range(図形右上セル).Offset(-2, -7).Value
   Else
    画像名 = AcSh.Range(図形右上セル).Offset(, 1).Value
   End If

の部分は、以下のようにまとめることができますが、わかりづらいでしょうか?

   With Obj.TopLeftCell.Offset(, Obj.BottomRightCell.Column - Obj.TopLeftCell.Column)
    If .Row <> 1 Then
     画像名 = .Offset(-3, -4).Value
     遠近 = .Offset(-2, -7).Value
    Else
     画像名 = .Offset(, 1).Value
    End If
    If 画像名 = "" Then
     画像名 = .Offset(-10, -4).Value
    End If
   End With

【61560】Re:画像の右上のセルに保存する画像名を...
お礼  ai  - 09/5/17(日) 21:40 -

引用なし
パスワード
   色々考えた結果できました!!
ありがとうございました(_ _)


Sub 画像Jpeg保存余白無し()
Dim AcSh As Worksheet, NwBk As Workbook
Dim Obj As Object, Crt As Chart, CrtNm As String
Dim Rgh As Double, Rgw As Double
Dim LT As String, BR As String, 図形右上セル As String
Dim 画像名 As String
Dim 遠近 As String

'現在のシートを省略して使う用にセット
Set AcSh = ActiveSheet
Set NwBk = Workbooks.Add
Set Crt = NwBk.Sheets(1).ChartObjects.Add(0, 0, Rgw, Rgh).Chart
CrtNm = Mid(Crt.Name, InStr(1, Crt.Name, " ") + 1)

For Each Obj In AcSh.DrawingObjects.ShapeRange
  'グループ化については無視。
  If Obj.Type = msoPicture Then

   '左上
   LT = Obj.TopLeftCell.Address
   '右下
   BR = Obj.BottomRightCell.Address
   図形右上セル = AcSh.Range(LT, BR).Rows(1).Cells(AcSh.Range(LT, BR).Rows(1).Cells.Count).Address
   If AcSh.Range(図形右上セル).Row <> 1 Then
     画像名 = AcSh.Range(図形右上セル).Offset(-3, -4).Value
      If 画像名 <> "" Then
        画像名 = AcSh.Range(図形右上セル).Offset(-3, -4).Value
      Else
        画像名 = AcSh.Range(図形右上セル).Offset(-14, -4).Value
      End If
     遠近 = AcSh.Range(図形右上セル).Offset(-2, -7).Value
   Else
     画像名 = AcSh.Range(図形右上セル).Offset(, 1).Value
   End If

   Rgh = Obj.Height - 0.5
   Rgw = Obj.Width - 0.5
   NwBk.Sheets(1).ChartObjects(CrtNm).Height = Rgh
   NwBk.Sheets(1).ChartObjects(CrtNm).Width = Rgw
   Obj.CopyPicture Format:=xlBitmap

   With Crt
     .Paste
     .ChartArea.Border.LineStyle = 0

     NwBk.Sheets(1).ChartObjects(CrtNm).Chart.Shapes(1).IncrementLeft -4
     NwBk.Sheets(1).ChartObjects(CrtNm).Chart.Shapes(1).IncrementTop -4
  
     .Export CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "R-" & 画像名 & "_" & 遠近 & ".jpg"
     DoEvents
   End With
   NwBk.Sheets(1).ChartObjects(CrtNm).Chart.Shapes(1).Delete
  End If
Next
NwBk.Sheets(1).ChartObjects(CrtNm).Delete
NwBk.Close (False)
Set AcSh = Nothing
Set NwBk = Nothing
Set Crt = Nothing
End Sub

3537 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free