以前に記載があった内容から、マクロを持ってきましたが、なかなか難易度が高くて、うまくできない状態です。
どなたか分かれば教えてください。
実施したい内容としては、マクロで
①エクセルシートの横列P10,R10,T10,V10,x10,z10,AB10,AD10,AF10,AH10までで1列空ける間隔で(難しい場合は、詰めた状態でもよいです)
縦列は約50行までの間に,ファルダ内のすべての写真が一括で各セルに画像を挿入
枚数は約200枚前後
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。
'//
Sub 図11R()
'No. 9024507
Dim strFilter As String
Dim Filenames() As Variant
Dim fName As Variant, ext As String
Dim PIC As Picture
Dim k As Long, m As Long
Dim i As Long, j As Long
Dim cnt As Long
Dim FirstRng As Range
Dim r As Range
Dim Sel_Folder As Object, Sel_Path As String
cnt = 0 'カウントの初期値
'貼り付け最初のセル
Set FirstRng = Range("A2")
Set Sel_Folder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 5)
If Not Sel_Folder Is Nothing Then
Sel_Path = Sel_Folder.Self.Path
Else
Exit Sub
End If
' 「ファイルを開く」ダイアログでファイル名を取得
ChDir Sel_Path
' strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
' Filenames = Application.GetOpenFilename( _
' FileFilter:=strFilter, _
' Title:="図の挿入(複数選択可)", _
' MultiSelect:=True)
fName = Dir("*.*", vbNormal)
Do While fName <> ""
If fName <> "." And fName <> ".." Then
ext = Mid(fName, InStrRev(fName, ".") + 1)
If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
cnt = cnt + 1
DoEvents
ReDim Preserve Filenames(1 To cnt)
Filenames(cnt) = fName
''安全のため(上限を設定)
If cnt > 100 Then Exit Do
End If
End If
fName = Dir()
Loop
If cnt = 0 Then Exit Sub
' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)
'' 貼り付け開始セルを選択
'Range("B6").Select
' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
k = LBound(Filenames)
m = UBound(Filenames)
For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
For i = 1 To 4
Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = r.Top ' 位置:アクティブセルの上側に重ねる
.Left = r.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = r.MergeArea.Height
End With
' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
' ActiveCell.Offset(5).Select
Set PIC = Nothing
k = k + 1
If k >= m Then Exit For
Next i
Next j
Application.ScreenUpdating = True
ChDir ThisWorkbook.Path
End Sub
A 回答 (3件)
- 最新から表示
- 回答順に表示
No.3
- 回答日時:
No2です
テストの都合上で、スタートのセルを一行ずらしていたのをそのまま投稿してしまいました。
わかるとは思いますが、念のため訂正しておきます。
誤:Set rng = Cells(11, 16)
正:Set rng = Cells(10, 16)
No.2
- 回答日時:
こんにちは
すでに回答がでていますし、単に「貼り付け位置(セル)を2列置きにする」だけなので、セルの位置を一つおきに制御すれば…と書いても、(多分)通じないのでしょうから、ご質問文の内容に会いそうな内容で作成してみました。
不明なのは(No1様も記述してらっしゃいますが)、貼付けの際のセルサイズと画像サイズの関係です。
およそ二通りの考えがあると思います。
・縦横比を無視してセルのサイズに合わせる
・縦横比を維持してできるだけ大きく表示
後者の場合は、余白ができる可能性がありますので、余白をどうするかということも関係してきます。
以下のコードは、とりあえず後者の「縦横比を維持する」例で、位置はセルの左上合わせとしています。
※ 位置やサイズの調整が必要な場合は、「画像ファイル読込みサイズ調整」の部分の修正でできると思います。
Sub Sample_11667960()
Dim dg, ext
Dim fPath As String, fName As String, n As String
Dim rng As Range, i As Integer
Dim sp As Shape, r As Double
ext = Split(".jpg,.jpeg,.gif,.bmp,.png", ",")
Set dg = Application.FileDialog(msoFileDialogFolderPicker)
If Not dg.Show Then Exit Sub
fPath = dg.SelectedItems(1) & "\"
Set rng = Cells(11, 16)
fName = Dir(fPath & "*")
While fName <> ""
n = LCase(fName)
For i = 0 To UBound(ext)
If Right(n, Len(ext(i))) = ext(i) Then
' 画像ファイル読込みサイズ調整
Set sp = ActiveSheet.Shapes.AddPicture(fPath & fName, _
False, True, rng.Left, rng.Top, 0, 0)
sp.ScaleWidth 1, True
sp.ScaleHeight 1, True
sp.LockAspectRatio = True
r = Application.Min(rng.Width / sp.Width, rng.Height / sp.Height)
sp.ScaleWidth r, True
sp.ScaleHeight r, True
Set rng = rng.Offset(, 2)
If rng.Column > 34 Then Set rng = rng.Offset(1, -20)
Exit For
End If
Next i
fName = Dir()
Wend
End Sub
No.1
- 回答日時:
①エクセルシートの横列P10,R10,T10,V10,x10,z10,AB10,AD10,AF10,AH10までで1列空ける間隔で(難しい場合は、詰めた状態でもよいです)
縦列は約50行までの間に,ファルダ内のすべての写真が一括で各セルに画像を挿入枚数は約200枚前後
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
②は、問題ないのでは?、
③は、すべてではないような?And Not fName Like "#*" Then なので数字が頭にあるとダメ?
④は、
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = r.MergeArea.Height
なので幅が合わない可能性があります。
縦横比維持しなくて良い?又は大きい方に合わせる?
維持しなくて良ければ
.LockAspectRatio = msoFalse
.Height = r.MergeArea.Height
.Width = r.MergeArea.Width
大きい方に合わせる?は If文で
.LockAspectRatio = msoTrue ' 縦横比維持
If .Height >= .Width Then
.Height = r.MergeArea.Height
Else
.Width = r.MergeArea.Width
End If
①は、やり方は色々あるかと思いますが、変数nを追加して
' 順番に画像を挿入
k = LBound(Filenames)
n = 0
For j = LBound(Filenames) To UBound(Filenames)
For i = 0 To 9
Set Pic = ActiveSheet.Pictures.Insert(Filenames(k))
Set r = FirstRng.Cells(9 + n, 16 + i * 2)
・
・
Set Pic = Nothing
k = k + 1
If k > UBound(Filenames) Then GoTo PicEND
Next
n = n + 1
Next
PicEND:
Application.ScreenUpdating = True
ChDir ThisWorkbook.Path
End Sub
ソートの部分など他の部分は分かりません。
未検証なので間違いがあるかも知れません。参考まで
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Visual Basic(VBA) Excel vbaについての質問 3 2023/04/18 16:14
- Visual Basic(VBA) ExcelVBAに関する質問 3 2023/02/17 10:47
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたいの続き 5 2023/01/24 00:16
- Excel(エクセル) フォルダ内のワードファイルをPDFに一括変換するVBA 3 2023/06/09 16:51
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) VBAでoutlook365が起動しません。 4 2022/08/25 13:31
- Visual Basic(VBA) 貼り付けた値が消えていく 以下はソースファイルの2番目のシートのB6から最終行を取得 ターゲットファ 2 2023/07/27 12:23
このQ&Aを見た人はこんなQ&Aも見ています
-
「環境が人を育てる」って本当?環境によって人格や生き方は本当に変わるのか
環境が人生に与える影響は実際どれほどのものなのか、専門家の田宮由美さんに伺った。
-
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
エクセル関数で画像を呼び出す方法ありますか?
Windows Vista・XP
-
-
4
マクロを実行すると画像がズレてしまいます
その他(Microsoft Office)
-
5
VBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)
Excel(エクセル)
-
6
VBAで選択した画像を貼り付けたい
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルのマクロについて教え...
-
特定のセルが空白だったら、そ...
-
Excelで指定した日付から過去の...
-
連続する複数のセル値がすべて0...
-
【Excel VBA】指定行以降をクリ...
-
i=cells(Rows.Count, 1)とi=cel...
-
VBAでセルをクリックする回...
-
セルの結果でマクロ実行
-
特定の文字を条件に行挿入とそ...
-
ExcelVBAを使って、値...
-
【Excel】指定したセルの名前で...
-
VBA初心者です。結合セルを保持...
-
”戻り値”が変化したときに、マ...
-
DataGridViewの各セル幅を自由...
-
HTMLでVLOOKUP関数のようなこと...
-
任意フォルダから画像をすべて...
-
【VBA】指定したセルと同じ値で...
-
結合したセルの高さを内容に合...
-
TODAY()で設定したセルの日付...
-
[Excel VB]プルダウンで文字選...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ExcelVBAを使って、値...
-
特定のセルが空白だったら、そ...
-
i=cells(Rows.Count, 1)とi=cel...
-
【Excel VBA】指定行以降をクリ...
-
Excelで指定した日付から過去の...
-
【Excel】指定したセルの名前で...
-
TODAY()で設定したセルの日付...
-
EXCELで変数をペーストしたい
-
Excel VBA、 別ブックの最終行...
-
Excelのプルダウンで2列分の情...
-
VBA コピーして次の値まで貼り...
-
screenupdatingが機能しなくて...
-
エクセルVBAでコピーして順...
-
VBA初心者です。結合セルを保持...
-
セル色なしの行一括削除
-
VBAでセルをクリックする回...
-
Excel vbaで特定の文字以外が入...
-
DataGridViewの各セル幅を自由...
-
特定の文字を条件に行挿入とそ...
-
【VBA】指定したセルと同じ値で...
おすすめ情報