[[20250512145323]]　『画像の転記』（社会人）　ページの最後に飛ぶ

『画像の転記』（社会人）

エクセルで「2025年まとめ」というシートと「1月」「2月」というように各月のシートがあります。

2025年まとめというシートには

　　 A| B| C| D| E|
1|　No.|画像|日付|画像|内容|
2| 1 | | 1月|　　|　 |
3| 2 | | 1月| | |
4| 3 | | 2月|　　|　 |
5| 5 | | 3月|　　|　 |
6| 7 | | 3月|　　|　 |
7| 8 | | 4月|　　|　 |
8| 9 | | 5月|　　|　 |

のようになっており
各月のシートは
例えば1月は
　　 A| B| C| D| E|
1|　No.|画像|日付|画像|内容|
2| 1 | | 1月|　　|　 |
3| 2 | | 1月| | |

2月は

 　　 A|   B|   C|   D|   E|
1|　No.|画像|日付|画像|内容|  
2|   1 |    | 2月|　　|　  |

このようなシートが各月分あり
まとめのシートのB2には「＝1月!B2」(横にフィル)(B3も同様)
B4には「＝2月!B2」(横にフィル)というように各月のシートが反映されるようになっています。
毎月新しいシートが追加されるのでまとめに追加していくような感じです。

ここで各月のシートの画像の部分には画像があります。
これをまとめのシートの対応セルに自動で貼り付けられるようにしたいのですが、なにか方法はないでしょうか？

現在はホームタブの検索と選択からオブジェクトの選択でまとめて選択してコピーしています。
このやり方より楽な方法があれば教えて頂きたいです。

＜使用 Excel：Excel2021、使用 OS：Windows11 ＞

全自動はＶＢＡ～♪　(*^^*)ｖ　らくですよ～

良い事ばかりではございませんで。。。作るのは四苦八苦。。。(￣▽￣；)
でわ
m(__)m
（隠居Z） 2025/05/12(月) 15:54:34

 1月は
 　 　 A|   B|   C|   D|   E|
 1|　No.|画像|日付|画像|内容|
 2|  1  |    | 1月|　　|　  | 
 3|  2  |    | 1月|    |    |

 2 月は

  　　 A|   B|   C|   D|   E|
 1|　No.|画像|日付|画像|内容|
 2|   1 |    | 2月|　　|　  |

 2025 年まとめというシートには

 　 　 A|   B| C  | D  | E  |
 1|　No.|画像|日付|画像|内容|
 2| 1   |    | 1月|　　|　 |
 3| 2   |    | 1月|    |   |
 4| 3   |    | 2月|　　|　 |
 5| 5   |    | 3月|　　|　 |
 6| 7   |    | 3月|　　|　 |
 7| 8   |    | 4月|　　|　 |
 8| 9   |    | 5月|　　|　 |

整理のお手伝いだけでも。。。(*^^*)　　m(__)m
（隠居Z） 2025/05/12(月) 16:21:17

https://support.microsoft.com/ja-jp/office/excel-%E3%81%AE%E3%82%BB%E3%83%AB%E5%86%85%E3%81%AB%E7%94%BB%E5%83%8F%E3%82%92%E6%8C%BF%E5%85%A5%E3%81%99%E3%82%8B-e9317aee-4294-49a3-875c-9dd95845bab0

  バージョンに依りますが、「セル内に画像を挿入する」とセル参照で画像も参照できます。
 2021でもpro plusならワンチャン
（´・ω・`） 2025/05/12(月) 16:27:02

隠居Zさま

すみません。書式が崩れてしまいました。整理していただきありがとうございます。
VBA...頑張ってみます(-_-;)
0から作れる技量はないのでAIに頼りながら作ってみようと思います。
いい報告ができるように頑張ります。

（´・ω・`）さま

各月のシートは社外から来てまして...
さらにエディションもHome and Businessでして...
提案していただいたのにすみません。

すみません以降の返答は少しお時間をいただくことになると思います。
（社会人） 2025/05/12(月) 17:22:18

言い出しべ～なので。。。作ってみました。が。。。^^;　合っているかどうかはわかりませ～ん(￣▽￣；)
2025年まとめ　シートは初期化されます。お試は新規ブックがよろしい様です。

ＡＩさんは　お返事くださいましたですか。(*^^*)
でわ
m(__)m

 Option Explicit
Sub IZ00000_OneInstanceMain()
    Dim CollectWsNm   As String
    Dim kAry()        As Variant
    Dim W()           As Variant
    CollectWsNm = "2025年まとめ"
    IZ00200_WsListMake kAry
    IZ00300_GetImgNmAndAdd kAry, CollectWsNm, W
    IZ00400_WArraySort W
    IZ00500_WriteToCollectionWs CollectWsNm, W
    Erase kAry, W
End Sub
Private Sub IZ00500_WriteToCollectionWs(ByVal CwsNm As String, ByRef W As Variant)
    Dim i             As Long
    Dim vAr           As Variant
    Dim y             As Long
    Dim r             As Range
    Dim x             As Long
    With Worksheets(CwsNm)
        .UsedRange.Clear
        .Cells.RowHeight = 85
        .Activate
        For Each vAr In .Shapes
            vAr.Delete
        Next
        .Cells(1).Resize(, 5) = Array("No.", "画像", "日付", "画像", "内容")
        y = 2
        Rem --------------------------------------------
        Rem      1      2      3    4   5   6      7
        Rem w =  Sheet Row Column Name NO. Date Content
        Rem --------------------------------------------
        For i = 1 To UBound(W, 1) - 1
            x = W(i, 3)
            .Cells(y, 1) = W(i, 5)
            Set r = .Cells(y, x)
            With .Cells(y, 3)
                .Value = CDate(W(i, 6))
                .NumberFormatLocal = "m月"
            End With
            .Cells(y, 5) = W(i, 7)
             Worksheets(W(i, 1) & "月").Shapes(W(i, 4)).Copy
            .Paste
            With .Shapes(.Shapes.Count)
                If .LockAspectRatio = True Then
                    .LockAspectRatio = False
                End If
                .Top = r.Top
                .Left = r.Left
                .Width = r.Width
                .Height = r.Height
            End With
            If W(i, 2) <> W(i + 1, 2) Then y = y + 1
        Next
        Application.CutCopyMode = False
        .Cells(1).Activate
    End With
End Sub
Private Sub IZ00400_WArraySort(ByRef W As Variant)
    Dim tmp           As Variant
    Dim App           As Object
    Set App = Application
    tmp = App.SortBy(W, App.Index(W, 0, 1), 1, App.Index(W, 0, 2), 1, App.Index(W, 0, 3), 1)
    W = tmp
    If IsArray(tmp) Then Erase tmp
End Sub
Private Sub IZ00300_GetImgNmAndAdd(ByRef kAry As Variant, ByVal CwsNm As String, ByRef W As Variant)
    Dim i             As Long
    Dim j             As Long
    Dim vAr           As Variant
    Dim TwsNm         As String
    Dim tStr          As Variant
    Dim rR            As Variant
    Dim cC            As Variant
    Dim DCB           As Object
    Dim tAry()        As Variant
    Set DCB = CreateObject("Scripting.Dictionary")
    For i = LBound(kAry) To UBound(kAry)
        TwsNm = kAry(i) & "月"
        With Worksheets(TwsNm)
            For Each vAr In .Shapes
                Rem R[y]C[x]
                tStr = Evaluate("REGEXREPLACE(""" & vAr.TopLeftCell.Address(1, 1, xlR1C1) & _
                       """,""R|\[|\]"","""",0,1)")
                rR = Split(tStr, "C")(0)
                cC = Split(tStr, "C")(1)
                j = j + 1
                DCB(j) = Array(kAry(i), rR, cC, vAr.Name, _
                               .Rows(rR).Cells(1).Value, _
                               .Rows(rR).Cells(3).Value, _
                               .Rows(rR).Cells(5).Value)
            Next
        End With
    Next
    ReDim W(1 To DCB.Count + 1, 1 To 8)
    tAry = DCB.keys
    For i = 0 To UBound(tAry)
        For j = 0 To UBound(DCB(tAry(i)))
            W(i + 1, j + 1) = DCB(tAry(i))(j)
        Next
    Next
    Erase tAry
    If IsArray(rR) Then Erase rR
    If IsArray(cC) Then Erase cC
    DCB.RemoveAll
End Sub
Private Sub IZ00200_WsListMake(ByRef k As Variant)
    Dim vAr           As Variant
    Dim tmp           As Variant
    Dim aL            As Object
    Set aL = CreateObject("System.Collections.ArrayList")
    For Each vAr In Worksheets
        If vAr.Name Like "*月" Then
            tmp = CLng(Left(vAr.Name, Len(vAr.Name) - 1))
            aL.Add tmp
        End If
    Next
    k = aL.ToArray
    aL.Clear
    Set aL = Nothing
End Sub
（隠居Z） 2025/05/21(水) 16:02:09

コメント返信：

[ 一覧(最新更新順) ]

[[20250512145323]] 『画像の転記』（社会人） ページの最後に飛ぶ

[[20250512145323]]　『画像の転記』（社会人）　ページの最後に飛ぶ