[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『図の複製』（ks）
日曜から土曜のカレンダーを作成している表があるのですが、日付の下のセルに図を貼ってます。
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ
１日 月 火 水 木 金 土
２ １ ２ ３ ４ ５ 6
３ 図 図 図 図 図 図
４７ ８ ９ 10
５図 図 図
１ ２ ３ ４ ５ ６ ７ ８ ９ 10
図 図 図 図 図 図 図 図 図 図
その図をコピーしてカレンダーの下の方に横向きに貼り付けるという作業をしてます。
同じ数字であれば数字の下の図を貼るようなことってできますか？
説明が下手でわかりにくかったらすいません。
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
できるだろうけど、その図形の左上が、必ず日付セルの直下でですかね？ セルからはみ出していたりすると、どの図形かの判断が難しくなるので・・・ 貼り付け先も、セルにセンタリングとかしないで、セルの左上に図の左上を合わせる形で サイズもそのままでいいんですかね？ ┌────────┐ │ 日付 │ ├────────┤ │↓ココ │ │┌──────┐│ ││＃＃図形＃＃││ │└──────┘│ └────────┘ ↓これだと難しい ┌────────┐ │ 日付 │ ├────────┤ │ │ ┌──────────┐ │＃＃＃＃図形＃＃＃＃│ └──────────┘ └────────┘ （稲葉） 2022/12/27(火) 15:44:36
こんな感じ？ 図といっても、様々な種類があり、質問からは読み取れなかったので、「AutoShape」を対象としています。
Public Sub 図の複製()
Dim TargetRng As Range, CalenderRng As Range
On Error Resume Next
Set CalenderRng = Application.InputBox( _
prompt:="カレンダーのセル範囲を選択してください。", Type:=8)
If Err.Number <> 0 Then Exit Sub
Set TargetRng = Application.InputBox( _
prompt:="貼り付け先の日付セル範囲（1行）を選択してください。", Type:=8)
If Err.Number <> 0 Then Exit Sub
If TargetRng.Areas.Count > 1 Or TargetRng.Rows.Count > 1 Then
MsgBox "日付セル範囲は複数行はNGです。", vbCritical
Exit Sub
End If
On Error GoTo 0
Dim shp As Object, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For Each shp In CalenderRng.Parent.Shapes
If shp.Type = msoAutoShape Then
If Not Intersect(shp.TopLeftCell, CalenderRng) Is Nothing Then
On Error Resume Next
dic(shp.TopLeftCell.Offset(-1).Value) = shp.Name
On Error GoTo 0
End If
End If
Next
Application.ScreenUpdating = False
TargetRng.Parent.Select
Call ShapeClear(TargetRng.Offset(1))
Dim r As Range
For Each r In TargetRng
If dic.Exists(r.Value) Then
CalenderRng.Parent.Shapes(dic(r.Value)).Copy
r.Offset(1).Select
r.Parent.Paste
End If
Next
End Sub
Private Sub ShapeClear(r As Range)
Dim shp As Object
For Each shp In r.Parent.Shapes
If shp.Type = msoAutoShape Then
If Not Intersect(shp.TopLeftCell, r) Is Nothing Then
shp.Delete
End If
End If
Next
End Sub
（まる） 2022/12/27(火) 22:42:22
まるさんと考えること同じだったけど、私のほうがだいぶ手抜きだあ
型指定しないで、範囲内にあるShapeで回せるオブジェクト全部移動させちゃう
Option Explicit
Sub test()
Dim sh As Object
Dim dic As Object
Dim tmp As Range
Dim i As Long
Dim カレンダー範囲 As Range
Dim コピー先 As Range
Set カレンダー範囲 = Range("A1:G11") '←環境に合わせて変えてください
Set コピー先 = Range("A16")
Set dic = CreateObject("Scripting.Dictionary")
For Each sh In ActiveSheet.Shapes
Select Case True
Case Not Intersect(sh.TopLeftCell, カレンダー範囲) Is Nothing
Set tmp = sh.TopLeftCell.Offset(-1)
If IsDate(tmp.Value) Then
Set dic(Day(tmp.Value)) = sh
End If
Case Not Intersect(sh.TopLeftCell, コピー先.Resize(, 31)) Is Nothing
sh.Delete
End Select
Next sh
For i = 1 To 31
If dic.exists(i) Then
コピー先.Offset(, i - 1).Activate
dic(i).Copy
ActiveSheet.Paste
End If
Next i
MsgBox "完了しました"
End Sub
（稲葉） 2022/12/28(水) 00:04:07
そういう重要な仕様は最初に書きましょう。
If shp.Type = msoAutoShape Then を If shp.Type = msoPicture Then に修正してください。
もう1ケ所、Forループの中で毎回エラートラップしている↓は、
On Error Resume Next dic(shp.TopLeftCell.Offset(-1).Value) = shp.Name On Error GoTo 0
1行目に「図」がある場合、Offset(-1)が例外を吐く対策で、想定できる例外処理なので以下に修正してください。 If shp.TopLeftCell.Row > 1 Then dic(shp.TopLeftCell.Offset(-1).Value) = shp.Name
自分は、ここまでとします。
（まる） 2022/12/28(水) 07:30:11
回答ではなく感想です。そもそもですが、 ・画像のプロパティを「セルに合わせて移動する・・・」にしておけば、 セル範囲を指定してコピーペイスとすれば、連動して画像もコピーペイスとされるはず。 質問に挙げた例であれば、2か所についてコピーペイスするだけでは？ ・数値を連動された画像にするということであれば、もともとのカレンダ形式にある 画像はどうやって挿入したのでしょう。そこは手作業なんですか？ それも併せて数値とファイル名の関連付けもセットで対応しないと効率化にはならないのでは？
（abc） 2022/12/28(水) 11:19:19
もともとカレンダーに画像が（おそらく手作業で）貼ってあるので、 一覧にしたいって要件だと思ってました・・・ （稲葉） 2022/12/28(水) 11:26:08
カレンダーのセル範囲を選択してください。
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ
１行１２月
２行 日 月 火 水 木 金 土
３行 １ ２ ３
４行 画 画 画 画 画 画 画
・
・
・
・
貼り付け先の日付セル範囲（1行）を選択してください。
１６行 Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ
１７行 １ ２ ３ ４ ５ ６ ７ ８
を指定しても画像が反映しません。
申し訳ないのですが操作方法を教えてください。
よろしくお願いします。
（ｋｓ） 2022/12/28(水) 12:45:28
１）E3の「1」は日付を書式設定で「1」に見せかけてますか？ ２）A17の「1」は、１）と同じものですか？ まるさんのコードは、貼り付け先の「日付」とカレンダーの「日付」が一致した場合貼り付けています。
私のコードは、面倒なのでどうせ1から順番に並んでるんだろうから、 1日から順番に張り付けていってるだけです。
操作方法を覚えるのではなく、コードの内容を理解して どこが希望通りの挙動にならないから、今一度ステップ実行で確認してみてください。
画像が貼れたけどズレてるとかなら分かりますが画像すら貼り付けられない状況です。
初心者には厳しいですかね、、、
（ks） 2022/12/28(水) 14:58:46
質問者さんのレイアウトで言うなら↓かな
「カレンダーのセル範囲を選択してください。」
→A3からG（の画像最終行）までの矩形
「貼り付け先の日付セル範囲（1行）を選択してください。」
→17行目（1行丸ごと）
（ufj） 2022/12/28(水) 15:28:02
>初心者には厳しいですかね、、、 手動でやるには （稲葉）さんの図で上のように 画像がセルの中に納まっているのならセルをコピーすれば図形も一緒にペーストできますよ。 （jm） 2022/12/28(水) 17:19:02
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.