編集履歴

質問編集履歴

コード削除

2015/11/26 23:27

投稿

cat_junko

スコア44

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -1,7 +1,3 @@
-下記のようなマクロコードがあります。
-実行すると結合した任意のセルに写真を貼り付けてくれます。
 複数選択で一括で貼り付けることができるとっても便利なコードなのですがこれを変更したいです。
 １、貼り付けた写真を結合セルの中央に持ってきたい。
@@ -20,342 +16,8 @@
 ------------------------------------------------
-'写真ファイルや図形ファイルなどの複数画像を一括で選択し、セルの行順(または任意のセル)に挿入します。
+１，２，３を、解決することが出来たのでコード削除しました。
-'セルのサイズに合わせて画像のサイズ縮小（または拡大）することもできます。
+-------------------------------------------------
-Dim n, fi, cc As Range, ya, ca, g, ok, fl, l
-Sub 複数画像の挿入()
-    Dim a, c, sr, sc, s, rr, pkfile, ar, ac, z, rc, ccc, ca0
-On Error GoTo err
-    Set a = Application.InputBox("画像を挿入するセルを選択してください" _
-            & Chr(13) & Chr(10) & "複数選択可 (ShiftキーまたはCtrlキーで選択)" _
-         , "複数画像の一括挿入（セル選択）", Selection.Address, , , , , 8)
-    Application.ScreenUpdating = False
-         a.Select
-        sr = Selection.Row
-        sc = Selection.Column
-    rr = sr
-pkfile = Application.GetOpenFilename _
-    ("すべての図(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif;*.eps), *.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif;*.eps", 2, "挿入する図の選択（複数選択可）", , True)
-If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
-    For fi = 1 To UBound(pkfile)
-       If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End 'キャンセルの場合終わる
-    Next fi
-n = ActiveSheet.Pictures.Count
-Application.DisplayAlerts = False
-z = MsgBox("画像のサイズをセルに合わせますか", vbYesNo, "複数画像の挿入")
-ok = 0
-If Application.Version < 12 Then
-    If MsgBox("縦横比を保持しますか", 4, "複数画像の一括挿入") = 6 Then ok = 0 Else ok = 1
-End If
-If z = 6 Then ya = MsgBox("画像圧縮しますか", vbYesNo, "複数画像の挿入")
-    l = MsgBox("元の画像へのリンクを作成しますか", 4 + 256)
-  ar = a.Address
- ac = Range(ar).Count
-fi = 1
-  If ac > 1 Then GoTo ech Else GoTo pc
-ech:
-    ca0 = ""
-   For Each cc In ActiveSheet.Range(ar)
-    ca = Range(cc.Address).MergeArea.Address
-    rc = Range(ca).Rows.Count
-    ccc = Range(ca).Columns.Count
-    If rc > 1 Or cc > 1 Then
-    ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
-    End If
-    If ca0 = ca Then GoTo mne
-    ca0 = ca
-    ca = Range(cc.Address).MergeArea.Address
-    Range(ca).Select
-'    cc.Select
-        g = ActiveSheet.Shapes.AddPicture( _
-            Filename:=pkfile(fi), _
-             LinkToFile:=False, _
-            SaveWithDocument:=True, _
-            Left:=Selection.Left, _
-            Top:=Selection.Top, _
-            Width:=400#, _
-            Height:=300#).Name
-'図のサイズを元のサイズに戻します
-    With ActiveSheet.Shapes(g)
-        .ScaleHeight 1!, msoTrue
-        .ScaleWidth 1!, msoTrue
-    End With
-        fl = pkfile(fi)
-'右のセルにファイル名を表示
-        Cells(Range(ca).Row, Range(ca).Column + 1) = fl
-        If z = 6 Then セルにサイズを合わせる
-        fi = fi + 1
-    If fi = UBound(pkfile) + 1 Then GoTo en
-mne:
-    Next
-    Application.DisplayAlerts = True
-    a.Select
-Exit Sub
-pc:
-    For fi = 1 To UBound(pkfile)
-        ca = Cells(rr, sc).Address
-        Range(ca).Select
-        g = ActiveSheet.Shapes.AddPicture( _
-            Filename:=pkfile(fi), _
-             LinkToFile:=False, _
-            SaveWithDocument:=True, _
-            Left:=Selection.Left, _
-            Top:=Selection.Top, _
-            Width:=400#, _
-            Height:=300#).Name
-'図のサイズを元のサイズに戻します
-    With ActiveSheet.Shapes(g)
-        .ScaleHeight 1!, msoTrue
-        .ScaleWidth 1!, msoTrue
-    End With
-        fl = pkfile(fi)
-'右のセルにファイル名を表示
-        Cells(Range(ca).Row, Range(ca).Column + 1) = fl
-        If z = 6 Then セルにサイズを合わせる
-        rr = rr + 1
-    Next fi
-Exit Sub
-en:
-Application.DisplayAlerts = True
-    Application.ScreenUpdating = False
-    a.Select
-Exit Sub
-err: MsgBox "選択が正しくありません", , "複数画像の一括挿入"
-End Sub
-Sub セルにサイズを合わせる()
-    Dim c As Range, cm As Range
-    Dim rX As Single, rY As Single, r As Single
-    Application.ScreenUpdating = False
-'    For Each c In Selection
-'        Set cm = c.MergeArea
-        Set cm = Range(ca)
-'        If c.Address = cm.Item(1).Address Then
- '           If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
-         ActiveSheet.Shapes(g).Select
-           With Selection
-                rX = cm.Width / .Width
-                rY = cm.Height / .Height
-                If ok = 0 Then
-                    If rX < rY Then
-                         cx = .Width * rX
-                         cy = .Height * rX
-                    Else
-                         cx = .Width * rY
-                         cy = .Height * rY
-                    End If
-                Else
-                 cx = cm.Width
-                 cy = cm.Height
-                 End If
-                    .Width = cx
-                    .Height = cy
-                    .Left = cm.Left
-                    .Top = cm.Top + cm.Height - .Height
-               If ya = 6 Then 図の圧縮
-            End With
- '       End If
- '  Next
-    Set cm = Nothing
-    Application.ScreenUpdating = True
-End Sub
-Sub 図の圧縮()
-    Selection.Cut
-    Range(ca).Select
-    ActiveSheet.PasteSpecial Format:="図 (JPEG)"
-        If l = 6 Then
-           ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=fl
-           Else
-            Cells(Range(ca).Row, Range(ca).Column + 1) = ""
-        End If
-        g = Selection.ShapeRange.Name
-End Sub
-------------------------------------------
-下記、サイトからの引用のようです。
-http://kiyopon.sakura.ne.jp/soft/fukuzu.htm
-（先輩が、作成したものではなかったようです）
-「エクセルの学校」にも、ここからの引用でこのコードをそのまま貼り付け各自の仕様にするために質問しているようです。
+画像を、載せたかったのですがまた載せられない状態になっているので時間をおいて載せたいと思います。
-なので、私も私仕様にしたいのでご教示願います。

引用追記

2015/11/26 23:27

投稿

cat_junko

スコア44

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -349,3 +349,13 @@
 End Sub
 ------------------------------------------
+下記、サイトからの引用のようです。
+http://kiyopon.sakura.ne.jp/soft/fukuzu.htm
+（先輩が、作成したものではなかったようです）
+「エクセルの学校」にも、ここからの引用でこのコードをそのまま貼り付け各自の仕様にするために質問しているようです。
+なので、私も私仕様にしたいのでご教示願います。