エクセル2007にて、クラスの集合写真から顔を選択して、セル内にピタッ

質問

エクセル2007にて、クラスの集合写真から顔を選択して、セル内にピタッと貼り付けたい。

エクセル2007を利用して名簿を作成しています。エクセルの表内の列にＮＯ、名前、顔写真、年齢、性別の項目がありるとします。その顔写真の列に、名簿に載っている人たちの顔の写真を入れたいと考えています。
顔の写真は、クラスの集合写真から一人ずつ範囲指定、コピーをし、次にエクセルのセル内に貼り付けています。しかしそのまま貼り付けると、セルからはみ出してしまいます。ぴたっとセル内に収まるように貼り付ける効率的な方法はありますか。
　全部で500人近い人の顔写真をいれる必要があるため、一人一人調整していると根気負けしそうです。教えてください。よろしくお願いします。

回答No.2

mitarashi · ベストアンサー

期待されている答えではありませんが、面白そうなので以前作成したものをアレンジしてみました。ワークシートに貼り付けた画像の、画像上に配置したオートシェープの四角（複数）で囲まれた部分をコピーして、指定セルに貼り付けます。xl2000と2010で動作確認しました。エラー処理等削りまくっても2K文字に収まらず、2つに分けます。

Sub trimingPhoto()
Dim myPic As Shape, myshp() As Shape
Dim mypicL As Double, mypicT As Double
Dim mypicW As Double, mypicH As Double
Dim myshpL As Double, myshpT As Double
Dim myshpW As Double, myshpH As Double
Dim cl As Double, ct As Double
Dim cr As Double, cb As Double
Dim i As Long
Dim picArea As Range
Dim errFlag As Boolean

On Error Resume Next
If (Err.Number <> 0) Or (Selection.ShapeRange.Type <> msoPicture) Then Exit Sub
On Error GoTo 0
Set myPic = ActiveSheet.Shapes(Selection.ShapeRange.Name)
Set picArea = Range(myPic.TopLeftCell, myPic.BottomRightCell)
myshp = getInsideRectangle(picArea)
If UBound(myshp) = 0 Then Exit Sub
For i = 1 To UBound(myshp)
mypicL = myPic.Left
mypicT = myPic.Top
mypicW = myPic.Width
mypicH = myPic.Height
With myshp(i)
If .Left < myPic.Left Then errFlag = True
If .Top < myPic.Top Then errFlag = True
If .Top + .Height > myPic.Top + myPic.Height Then errFlag = True
If .Left + .Width > myPic.Left + myPic.Width Then errFlag = True
End With
If errFlag Then Exit Sub
myshpL = myshp(i).Left
myshpT = myshp(i).Top
myshpW = myshp(i).Width
myshpH = myshp(i).Height
cl = myshpL - mypicL
ct = myshpT - mypicT
cr = (mypicW - myshpW) - cl
cb = (mypicH - myshpH) - ct
With myPic.PictureFormat
.CropLeft = cl
.CropTop = ct
.CropRight = cr
.CropBottom = cb
Selection.Copy
Cells(i, 1).Activate
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:= _
False
.CropLeft = 0
.CropTop = 0
.CropRight = 0
.CropBottom = 0
End With
myPic.Select
Next i
Set myPic = Nothing
End Sub

お礼

作っていただいて、ありがとうございます。
使い方をまとめてみました。

１．集合写真をエクセルに、コピー貼り付けする.
この時、集合写真をA列から離れたところに貼り付けておく。
２．Sub makeRect()のマクロを利用して、同じ大きさの四角を必要分だけ作る。デフォルトは10個、マクロエディタ上で数値を必要個数分、増減しておく。
３．集合写真上に四角を移動して、顔部分を指定する。
３．集合写真自体を選んで、trimingPhoto()マクロを実行する。
４．A列に顔写真が順に並ぶ。
５．他の方が作られた以下のマクロで、写真を貼り付け先のセルの大きさへ調整する。
Sub Macro1()
' Macro1 Macro
' Keyboard Shortcut: Ctrl+t
Dim pic As Shape
For Each pic In ActiveSheet.Shapes
With pic.TopLeftCell
pic.LockAspectRatio = msoFalse
pic.Top = .Top
pic.Left = .Left
pic.Width = .Width - 5
pic.Height = .Height - 5
pic.Placement = xlMoveAndSize
'Selection.Placement = xlMoveAndSize
End With
Next
End Sub
助かりました。

回答No.3

mitarashi

#2の続きです。#2で書き落としましたが、目的画像を選択後実行しないと、無言で終了します。（他にもエラー処理を削ったので、無言で終了する箇所があります）

Private Function getInsideRectangle(targetRange As Range) As Shape()
Dim shp As Shape
Dim rectRange As Range
Dim shps() As Shape

ReDim shps(0 To 0)
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then
If shp.AutoShapeType = msoShapeRectangle Then
Set rectRange = Range(shp.TopLeftCell, shp.BottomRightCell)
If Not Intersect(rectRange, targetRange) Is Nothing Then
ReDim Preserve shps(0 To (UBound(shps) + 1))
Set shps(UBound(shps)) = shp
End If
End If
End If
Next shp
getInsideRectangle = shps
End Function

'おまけ　連番入りの四角を作成。四角を作成した順にトリミング＆貼り付けられる筈ですので。
’サイズは適当にアレンジして下さい。この部分は2010では未検証です。
Private Sub makeRect()
Dim i As Long
Dim rectWidth As Double, rectHeight As Double
Dim myRect As Shape

rectWidth = 50
rectHeight = 40
For i = 1 To 10 'お好きな数だけどうぞ
Set myRect = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, i * (rectHeight + 10), rectWidth, rectHeight)
With myRect
.Fill.Visible = msoFalse
.Line.Weight = 1.5
.Line.ForeColor.SchemeColor = 13
.TextFrame.Characters.Text = Format(i, "00")
With .TextFrame.Characters(Start:=1, Length:=2).Font
.Name = "ＭＳ Ｐゴシック"
.Size = 11
.ColorIndex = 6
End With
End With
Next i
End Sub

回答No.1

conanthe

Altキーを押しながら、写真を移動したり、サイズ変更をしてください。そうすれば一番近い枠にぴたっとはり付くように移動したりサイズが変わったります。

お礼

ありがとうございます。助かります。