- ベストアンサー
エクセルで複数画像を一括挿入する方法
iphqwoの回答
- iphqwo
- ベストアンサー率21% (10/47)
コメントに注意事項 記載いたしました。 Sub MakeThumbnail() Dim myDataCnt As Long Dim myNo As Long Dim i As Long Dim myRow As Long Dim myName As String myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row myNo = 1 myRow = 2 Worksheets("picture").Select Do Until myNo > myDataCnt myName = Worksheets("data").Cells(myNo, 1).Value Cells(myRow, 2).Select ActiveSheet.Pictures.Insert(myName).Select With Selection '.Left = Range("A1").Left 'コレらを指定することにより '.Top = Range("A1").Top '毎回A1にインサートするので駄目です .ShapeRange.LockAspectRatio = msoTrue ' .ShapeRange.Height = 76.5 '高さ指定が抜けてます .ShapeRange.Width = 102# ' End With myRow = myRow + 6 '1 は駄目です myNo = myNo + 1 Loop End Sub
関連するQ&A
- エクセル マクロ 写真貼り付け
エクセル マクロ 写真貼り付け よろしくお願いします。 以前ここで、エクセルに写真を張り付けるマクロのコードが乗っていたので、それを使わせていただいていたのですが、PCを入れ替えてからうまく動作してくれません。どなたか修正個所を教えていただけると助かります。 OS ビスタ エクセル 2007 "data"シートに貼付する写真のあるフォルダのパス、写真ファイル名が張り付ける分だけ表記されていて、"picture"シートに"data"シートの指定した写真を張り付けていきます。 A4用紙に以前はB3セル辺りから写真を指定の大きさに張り付け、次のページに移動してB37セルB71セルB105セルと写真貼り付けをしてくれましたが、PC入れ替え後から写真が1ページ目のB3セルに重ねて張り付けられてしまいます。 以前のように各ページに1枚ずつ写真を指定の大きさに張り付けるにはどうしたらよいのでしょうか。 以前はOS XP エクセル2003でした。 マクロに関しては素人です。どうかよろしくお願いします。 Sub MakeThumbnail() Cells.Select Selection.RowHeight = 22.5 Dim myDataCnt As Long Dim myNo As Long Dim i As Long Dim myRow As Long Dim myName As String myDataCnt = Worksheets("data").Range("A1").End(xlDown).Row myNo = 1 myRow = 2 Worksheets("picture").Select Do Until myNo > myDataCnt myName = Worksheets("data").Cells(myNo, 1).Value Cells(myRow, 2).Select ActiveSheet.Pictures.Insert(myName).Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Width = 200# myRow = myRow + 12 myNo = myNo + 1 Loop End Sub
- ベストアンサー
- その他MS Office製品
- 画像をエクセルに貼り付けるマクロ
画像をエクセルに貼り付けるマクロ 複数の画像をエクセルに貼り付ける機会が多く、下記のマクロを利用しています。これは他人が作ったものでその人が今はいないため修正の仕方がわかりません。 これだとヨコに2個の画像で縦方向に画像が貼り付けられます。これをヨコに3個の画像で 縦方向に画像を貼り付けるようにしたいのですが、方法がわかりません。 お詳しい方どうかよろしくお願いします。 <現在> 1 2 3 4 5 6 <やりたいこと> 1 2 3 4 5 6 7 8 9 Sub Insertpic() Dim strFilter As String Dim Filenames As Variant Dim pic As picture Dim sc As Range Dim i As Long Dim j As Long Dim k As Long '「ファイルを開く」ダイアログでファイル名を取得 strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png" Filenames = Application.GetOpenFilename( _ FileFilter:=strFilter, _ Title:="画像の挿入(複数画像が選択できます)", _ MultiSelect:=True) If Not IsArray(Filenames) Then Exit Sub ' 貼り付け開始セルを選択 'ActicveCellRange("C5").Select ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 For i = LBound(Filenames) To UBound(Filenames) Set pic = ActiveSheet.Pictures.Insert(Filenames(i)) '画像の大きさ指定 With pic.ShapeRange .Height = 120# .Width = 175# .Rotation = 0# End With ' 次の貼り付け先を選択 Select Case i Mod 2 Case 1 '奇数回目 ActiveCell.Offset(, 4).Select Case 0 '偶数回目 ActiveCell.Offset(11, -4).Select End Select Set pic = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ 方法
以下のようなマクロを作りましたが、帳票を印刷すると1枚印刷されます。 ですが、この帳票がA5サイズの決まりがあり、かつプリンタがA4しか用紙を入れることができないので、 そのため、一度にA5サイズの帳票を2枚合わせた形で印刷をさせたいと考えています。 A4用紙に左側(名簿の1番目)右側(名簿の2番目) 次も、名簿の3番目・4番目と連続印刷をしたいのですが、どのようにすれば良いのでしょうか。 勉強不足で申し訳ございませんが、ご指南くださいますようお願いいたします。 Sub 帳票印刷() Dim LastRow As Long Dim i As Long Dim myNo As Variant With Worksheets("名簿") LastRow = .Cells(Application.Rows.Count, "A").End(xlUp).Row For i = 2 To LastRow myNo = .Range("A" & i).Value With Worksheets("印刷用") .Range("C4").Value = myNo .PrintPreview .PrintOut Copies:=1, Collate:=True End With Next i End With End Sub
- 締切済み
- Visual Basic
- エクセル2007のマクロで画像挿入がうまくいきません。
エクセル2007のマクロで画像挿入がうまくいきません。 写真のサイズ縦横比がセルにあっていないので伸びてしまいます。 下記のプログラムでサイズ変更も可能でしょうか? フォームのボタンの上に張り付けた場合、ボタンを隠す事は 出来ますか? ボタンの色は変更できるのでしょうか? いろいろわがままな質問で申し訳ありません。 マクロ初心者です。 Sub Pic_in2007() fname = Application.GetOpenFilename ActiveSheet.Pictures.Insert(fname).Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = range("B5:C6").height Selection.ShapeRange.Width = range("B5:C6").width Selection.ShapeRange.left = range("B5:C6").left Selection.ShapeRange.top = range("B5:C6").top End Sub
- ベストアンサー
- オフィス系ソフト
- Excel 2010マクロで挿入した画像に名前が付けられない!
Excel 2010マクロで挿入した画像に名前が付けられない! Excel 2002で作成・使用していた画像挿入修正マクロを、Excel 2010で実行したところ、 下記プログラムの下から二行目の「ActiveSheet.Shapes(na11).Name = "ga1"」部分で 「指定したコレクションに対するインデックスが境界をこえています」とのことで エラー!になります。 na11 = Selection.ShapeRange.ZOrderPosition ActiveSheet.Shapes(na11).Name = "ga1" 上記の部分のみを、Excel 2010で実行すると正常に作動します。 原因がわかりません。ご指導よろしくお願いいたします。 ※下記プログラムの「¥」は文字化けするため、全角に置き換えております。 ------------------------------------------------------ ' 画像(1)を自動配置する If Range("AQ18").Value = 0 Then Else san = Range("DA17").Value san2 = Right(san, Len(san) - InStrRev(san, "-") + 1) d = Left(san, Len(san) - Len(san2)) myPath = pa & "¥" & a & "¥" & a & " " & b & " " & k & "¥" & d & "¥" & d & "-PHOTO" & "¥" & d & "_web" Range("H42").Select ActiveSheet.Pictures.Insert(myPath & "¥" & san).Select ' 画像(1)を縮小し、名前を付ける Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Width = size1 Selection.ShapeRange.Rotation = 0# na11 = Selection.ShapeRange.ZOrderPosition ActiveSheet.Shapes(na11).Name = "ga1" End If --------------------------------------------------
- ベストアンサー
- その他MS Office製品
- Excelマクロのことで教えて下さい
初歩的なことですみません。 E列の値をF列に値を入れるために下記のマクロを組みました。 Sub test() Worksheets("Sheet1").Select Dim i As Long For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row Range("F2").Value = "=E2/1024/1024" Cells(i, 6).FillDown Range(Cells(2, 6), Cells(i, 6)).Copy Range("F2").PasteSpecial Paste:=xlValues Next i End Sub ところがF列に「値のみを貼り付け」をした時に、途中から同じ値のみがコピーされてしまい困っています。 (画像参照) うまく貼り付けることができるマクロをお教え下さい。 よろしくお願いいたします。
- ベストアンサー
- Excel(エクセル)
- エクセル マクロ picture
教えてもらいながら以下のような画像貼り付けマクロを組んだのですが,以下の点に引っかかり前進することができません. 教えて頂きたいと思い投稿しました. 躓いている点 シート内でボタンを利用して貼り付け及び削除をしているのですが,エクセルシート内でコピペするたびに「Selection.Name」と貼り付け先を修正しています. →これをコピペしても修正をしなくてもよいマクロはないでしょうか? 自作作成マクロ Sub 写真貼付1_Click() Dim AA As String, BB As String, CC As String 10 AA = InputBox("参照先を指定して下さい。例:D:\Photo001.jpg", "場所指定", AA) If (AA = "") Then AA = Application.GetOpenFilename(Title:="写真ファイルの場所はどこですか?") GoTo 10 End If ActiveSheet.Unprotect Range("m29").Select ActiveSheet.Pictures.Insert(AA).Select Selection.Name = "写真1" Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Height = 310 Selection.ShapeRange.Width = 310# Selection.ShapeRange.IncrementLeft 1 Selection.ShapeRange.IncrementTop 1 ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True End Sub -------------------------------------------------- Sub 写真削除1_Click() ActiveSheet.Shapes("写真1").Select Selection.Delete ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True End Sub ところどころ端折ってますが,以上のようなマクロです. よろしくお願いします.
- ベストアンサー
- オフィス系ソフト
- 複数行を最終行に転記
ブックから他ブックへの複数行を最終行に転記したいと考えております。 1日1行であれば転記出来るものの、1日が複数行となると1日の最終行のみが転記され困っております。 縦カレンダー仕様 ・月初ではなく日曜始まりの為前月含むこともあり ・1日につき各4行づつ ・4行すべて毎日データーが入るわけではなく時々入る程度 スケジュール表仕様 ・日曜始まりの一週間毎のシート ・1日につき9行分 1か月分だと長いので1週目分だけですが… Activ bookを縦カレンダー(入力用シート) Thisbookをスケジュール表(転記先シート) Sub 転記_Click() Dim WBK1 As Workbook,WBK2 As Workbook Dim SH1 As Worksheet,SH2 As Worksheet Dim myRow1 As Long,myRow2 As Long,myRow3 As Long,myRow4 As Long_ myRow5 As Long,myRow6 As Long,myRow7 As Long Set WBK1 = ThisWorkbook '縦カレンダー Set WBK2 = ActiveWorkbook 'スケジュール表 Set SH1 = WBK1.Worksheets("1週目") 'スケジュール表 Set SH2 = WBK2.Worksheets("3月") '縦カレンダー Set SH3 = WBK1.Worksheets("2週目") 'スケジュール表 Set SH4 = WBK1.Worksheets("3週目") 'スケジュール表 Set SH5 = WBK1.Worksheets("4週目") 'スケジュール表 Set SH6 = WBK1.Worksheets("5週目") 'スケジュール表 Set SH7 = WBK1.Worksheets("6週目") 'スケジュール表 With SH1 myRow1 = SH1.Range("C1").End(xlDown).Row '日 myRow2 = SH1.Range("C12").End(xlDown).Row '月 myRow3 = SH1.Range("C23").End(xlDown).Row '火 myRow4 = SH1.Range("C34").End(xlDown).Row '水 myRow5 = SH1.Range("C45").End(xlDown).Row '木 myRow6 = SH1.Range("C56").End(xlDown).Row '金 myRow7 = SH1.Range("C67").End(xlDown).Row '土 SH1.Range("C" & myRow1 + 1 & ":J" & myRow1 + 1).Value = SH2.Range("C3:J6").Value '日 SH1.Range("C" & myRow2 + 1 & ":J" & myRow2 + 1).Value = SH2.Range("C7:J10").Value '月 SH1.Range("C" & myRow3 + 1 & ":J" & myRow3 + 1).Value = SH2.Range("C11:J14").Value '火 SH1.Range("C" & myRow4 + 1 & ":J" & myRow4 + 1).Value = SH2.Range("C15:J18").Value '水 SH1.Range("C" & myRow5 + 1 & ":J" & myRow5 + 1).Value = SH2.Range("C19:J22").Value '木 SH1.Range("C" & myRow6 + 1 & ":J" & myRow6 + 1).Value = SH2.Range("C23:J26").Value '金 SH1.Range("C" & myRow7 + 1 & ":J" & myRow7 + 1).Value = SH2.Range("C27:J30").Value '土 End With End Sub
- 締切済み
- Visual Basic
- EXCEL マクロ 条件によるセルの色付け
お世話になります。 マクロは初心者です。 C列の数値1~6によって、E列に色付けしたく、ネットで色々検索して、 下記のように組んだのですがコマンドボタンクリックでは上手く動かない のですが、どのように修正すればよいのでしょうか。教えて下さい。 宜しくお願いします。 Private Sub CommandButton4_Click() Dim i As Range Dim r As Range Dim c As Range Dim myColor As Long Set i = Worksheets("マスタ").Range("C:C") Set r = Worksheets("マスタ").Range("E:E") If Intersect(Target, i) Is Nothing Then Exit Sub For Each c In Intersect(Target, i) With c Select Case .Value Case "1" myColor = 22 Case "2" myColor = 44 Case "3" myColor = 6 Case "4" myColor = 43 Case "5" myColor = 41 Case "6" myColor = 24 Case Else myColor = xlColorIndexNone End Select Intersect(c.EntireRow, r).Interior.ColorIndex = myColor End With Next End Sub
- ベストアンサー
- その他MS Office製品
- マクロ初心者です。画像一括挿入について
初めてマクロを使っております。 以下ネットで拾ってきましたコードなのですが、 行いたいのは (1)挿入するセルを選択(複数可) (2)画像を一括選択 (3)縦横比率を固定して挿入:横か縦の長さは自分で設定 ※今のコードですと(3)で比率の固定ができず、伸びた画像が挿入されてしまいます これを可能にするには、一体どこをどう変えたらよいのでしょうか。 慣れない画像編集に悪戦苦闘しております。 どなたかご教授いただけますと幸いです。 どうぞよろしくお願い致します。 Sub try() Dim a As Range Dim cc As Range Dim W As Single Dim H As Single Dim mx As Long Dim fi As Long Dim i As Long Dim pkfile On Error GoTo extLine With Application Set a = .InputBox("画像挿入するセル選択" & vbLf & _ "複数選択可", _ "複数画像の一括挿入(セル選択)", _ Selection.Address, _ Type:=8) pkfile = .GetOpenFilename("すべての図" & _ "(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif)," & _ "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _ "*.jpe;*.png;*.bmp;*.gif", 2, _ "挿入する図の選択(複数選択可)", , True) If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , _ "複数画像の一括挿入" GoTo extLine End If W = .InputBox("ヨコ", Type:=1) H = .InputBox("タテ", Type:=1) .ScreenUpdating = False End With mx = UBound(pkfile) fi = 1 For Each cc In a If cc.Address = cc.MergeArea.Item(1).Address Then Call picIns(cc, pkfile(fi), W, H) fi = fi + 1 If fi > mx Then Set cc = Nothing Exit For End If End If Next For i = fi To mx Set a = a(a.Rows.Count, 1).Offset(1) Call picIns(a, pkfile(i), W, H) Next extLine: Set a = Nothing Application.ScreenUpdating = False With err() If .Number <> 0 Then MsgBox .Number & ":" & .Description End With End Sub Sub picIns(ByVal r As Range, _ ByVal s As String, _ ByVal W As Single, _ ByVal H As Single) With ActiveSheet.Pictures.Insert(s).ShapeRange If (W > 0) And (H > 0) Then .LockAspectRatio = msoFalse .Width = W .Height = H ElseIf W > 0 Then .Width = W ElseIf H > 0 Then .Height = H End If .Left = r.Left .Top = r.Top End With End Sub
- ベストアンサー
- Excel(エクセル)
お礼
早速のご返信ありがとうございます! ご教授いただいた箇所の削除と、高さ指定、最終4行目を+6に の合計3箇所 修正してみましたが、画像がやはり重なったままで、A4とB4にまたがって挿入されてしまいます。 エクセル自体の設定でなにかまずいのでしょうか?