Sub 集計データを表に持ってくる()

Sub 集計データを表に持ってくる()
    Dim srcSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastRowSrc As Long
    Dim destRow As Long
    Dim i As Long
    Dim destRange As Range
    
    ' 集計シートを設定
    Set srcSheet = ThisWorkbook.Sheets("集計") ' 集計シートの名前に変更してください
    
    ' 貼付シートを設定
    Set destSheet = ThisWorkbook.Sheets("貼付") ' 貼付シートの名前に変更してください
    
    ' 集計シートのC列の最終行を取得
    lastRowSrc = srcSheet.Cells(srcSheet.Rows.Count, "C").End(xlUp).Row
    
    ' 貼付シートのD列の次の空白行を取得
    destRow = destSheet.Cells(destSheet.Rows.Count, "D").End(xlUp).Row + 1
    
    ' 貼付シートのD列を範囲として取得
    Set destRange = destSheet.Range("D2:D" & destRow - 1)
    
    ' データをコピーして貼り付け
    For i = 2 To lastRowSrc ' 2から始めることでヘッダー行をスキップ
        If srcSheet.Cells(i, 3).Value >= 1 Then
            ' 数値が1以上かつD列に存在しない場合、左隣のセルの値をD列に追加
            If WorksheetFunction.CountIf(destRange, srcSheet.Cells(i, 2).Value) = 0 Then
                destSheet.Cells(destRow, 4).Value = srcSheet.Cells(i, 2).Value
                destRow = destRow + 1
            End If
        End If
    Next i
    
    MsgBox "データが追加されました。", vbInformation
End Sub

Sub VLOOKUP適用()
    Dim destSheet As Worksheet
    Dim srcSheet As Worksheet
    Dim lastRowDest As Long
    Dim lastRowSrc As Long
    Dim destRange As Range
    Dim cell As Range
    
    ' 貼付シートを設定
    Set destSheet = ThisWorkbook.Sheets("貼付") ' 貼付シートの名前に変更してください
    
    ' 集計シートを設定
    Set srcSheet = ThisWorkbook.Sheets("集計") ' 集計シートの名前に変更してください
    
    ' 貼付シートのD列の最終行を取得
    lastRowDest = destSheet.Cells(destSheet.Rows.Count, "D").End(xlUp).Row
    
    ' 集計シートのB列の最終行を取得
    lastRowSrc = srcSheet.Cells(srcSheet.Rows.Count, "B").End(xlUp).Row
    
    ' 貼付シートのD列を範囲として取得
    Set destRange = destSheet.Range("D8:D" & lastRowDest)
    
    ' H列にVLOOKUP関数を適用
    For Each cell In destRange
        cell.Offset(0, 4).Formula = "=IFERROR(IF(VLOOKUP(" & cell.Address & ",集計!B2:AA" & lastRowSrc & ",2,0)<>0,VLOOKUP(" & cell.Address & ",集計!B2:AA" & lastRowSrc & ",2,0),""""),"""")"
    Next cell
    
    ' J列にVLOOKUP関数を適用
    For Each cell In destRange
        cell.Offset(0, 6).Formula = "=IFERROR(IF(VLOOKUP(" & cell.Address & ",集計!B2:AA" & lastRowSrc & ",3,0)<>0,VLOOKUP(" & cell.Address & ",集計!B2:AA" & lastRowSrc & ",3,0),""""),"""")"
    Next cell
    
    ' 結果が0の場合は空白にするために数式を値に変換
    ' 数式を値に変換する
    destSheet.Range("H8:H" & lastRowDest).Value = destSheet.Range("H8:H" & lastRowDest).Value
    destSheet.Range("J8:J" & lastRowDest).Value = destSheet.Range("J8:J" & lastRowDest).Value
    
    MsgBox "VLOOKUP関数が適用されました。", vbInformation
End Sub
Sub 数字に応じ画像()
    Dim destSheet As Worksheet
    Dim imageSheet As Worksheet
    Dim lastRowDest As Long
    Dim cell As Range
    Dim pictureName As String
    Dim picture As picture
    Dim title As Range

    ' 貼付シートを設定
    Set destSheet = ThisWorkbook.Sheets("貼付") ' 貼付シートの名前に変更してください
    
    ' 画像シートを設定
    Set imageSheet = ThisWorkbook.Sheets("画像") ' 画像シートの名前に変更してください
    
    ' 貼付シートのH列の最終行を取得
    lastRowDest = destSheet.Cells(destSheet.Rows.Count, "H").End(xlUp).Row

    ' H列に基づいて画像を貼り付ける
    For Each cell In destSheet.Range("H1:H" & lastRowDest)
        If cell.Value >= 1 And cell.Value <= 4 Then
            ' 値が1以上4以下の場合、"トラ"の画像を貼り付け
            pictureName = "トラ"
        ElseIf cell.Value >= 5 Then
            ' 値が5以上の場合、"シンスタ"の画像を貼り付け
            pictureName = "シンスタ"
        Else
            ' それ以外の場合は何もしない
            pictureName = ""
        End If

        ' 画像が指定されていれば、画像を取得してセルに貼り付け
        If pictureName <> "" Then
            Set picture = GetImageByName(imageSheet, pictureName)
            If Not picture Is Nothing Then
                picture.Copy
                cell.Offset(0, -1).PasteSpecial Paste:=xlPasteValues
                Set title = cell.Offset(0, -1)
                With destSheet.Shapes(destSheet.Shapes.Count)
                    .LockAspectRatio = msoFalse
                    .Top = title.Top + (title.Height - ActiveSheet.Shapes(destSheet.Shapes.Count).Height) / 2
                    .Left = title.Left + (title.Width - ActiveSheet.Shapes(destSheet.Shapes.Count).Width) / 2
                End With
                Application.CutCopyMode = False
            End If
        End If
    Next cell
    
    MsgBox "画像が貼り付けられました。", vbInformation
End Sub

Function GetImageByName(imageSheet As Worksheet, imageName As String) As picture
    Dim picture As picture

    ' 画像シートから画像を取得
    For Each picture In imageSheet.Pictures
        If picture.Name = imageName Then
            Set GetImageByName = picture
            Exit Function
        End If
    Next picture

    ' 該当する画像が見つからない場合は Nothing を返す
    Set GetImageByName = Nothing
End Function