Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
3538 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【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
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
3538 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free