- ベストアンサー
VBAで特定の文字が含まれている画像ファイル
- VBAを使用して特定の文字が含まれている画像ファイルを処理する方法について学びます。
- 下記のコードを使用して、画像を適切な位置に貼り付ける方法を説明します。
- また、セルの内容に応じて画像を貼り付ける位置を制御する方法も紹介します。
- みんなの回答 (2)
- 専門家の回答
関連するQ&A
- Excelマクロのオフセットについて
マクロのセルのオフセットについて質問です。 複数の画像(仮に7枚)を一度に張り付ける際に If ActiveCell.Column = 1 Then ActiveCell.Offset(, 8).Select Else ActiveCell.Offset(4, -8).Select End If このようなマクロ組むと 1 2 3 4 5 6 7 という感じになります。 列は8列空いて、行は4行空くことになると思うのですが これを 1 2 3 4 5 6 7 としたい場合はどのようなマクロの書き方をすればよいのでしょうか? ご指導の程宜しくお願いします。マクロを張り付けておきます。 Declare Function SetCurrentDirectory Lib "kernel32" Alias _ "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long Sub 画像一括貼り付け() Dim Fname As Variant, fe As Variant Dim Fn As Variant, Pic As Shape Dim pno As Long Dim myFileName As String Range("A8").Select SetCurrentDirectory "P:\投レ+相模原\F-POT KBB42365\外観確認" Fname = Application.GetOpenFilename _ ("jpg,*.jpg,jpeg,*.jpeg,bmp,*.bmp,gif,*.gif,png,*.png", MultiSelect:=True) If Not IsArray(Fname) Then MsgBox "取り消されました。", vbInformation Exit Sub End If Application.ScreenUpdating = False pno = 0 For Each Fn In Fname 'この次へ追加すべき行 Selection.Offset(-1, 0) = Mid(Fn, InStrRev(Fn, "\") + 1, Len(Fn) - InStrRev(Fn, "\")) ActiveCell.Select Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=Fn, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=0, Top:=0, Width:=360, Height:=270) With Pic .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue .Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない End With If ActiveCell.Column = 1 Then ActiveCell.Offset(, 8).Select Else ActiveCell.Offset(4, -8).Select End If Set Pic = Nothing pno = pno + 1 Next Application.ScreenUpdating = True Range("A1").Select MsgBox pno & "枚の画像を挿入しました", vbInformation End Sub
- ベストアンサー
- Excel(エクセル)
- VBAのキー入力待ちでCPU負荷大
VBAでキー入力待ちで動作をするプログラムを組んでいますが、 プログラムの組み方が悪くCPUの負荷が高くなり、CPUの温度が かなり上がってしまいます。 いろいろ調べたのですがわかりません。 負荷を下げるプログラムの書き方を教えていただけないでしょうか。 Excel2010です。 よろしくお願いします。 Sub ボタン1_Click() Dim i, j, k, Maxrow, Colst, colen, nCnt As Integer Do Until GetAsyncKeyState(27) If GetAsyncKeyState(75) <> 0 Then ・ ・ 「モジュールプログラム1」 ・ ・ Do Until GetAsyncKeyState(75) = 0 Loop ElseIf GetAsyncKeyState(77) <> 0 Then ・ ・ 「モジュールプログラム2」 ・ ・ Do Until GetAsyncKeyState(77) = 0 Loop ElseIf GetAsyncKeyState(37) <> 0 Then If ActiveCell.Column > 1 Then ActiveCell.Offset(0, -1).Activate End If ElseIf GetAsyncKeyState(38) <> 0 Then If ActiveCell.Row > 1 Then ActiveCell.Offset(-1, 0).Activate End If ElseIf GetAsyncKeyState(39) <> 0 Then ActiveCell.Offset(0, 1).Activate ElseIf GetAsyncKeyState(40) <> 0 Then ActiveCell.Offset(1, 0).Activate End If For k = 1 To 300: Next k Loop Sheets("Main").Activate End Sub
- ベストアンサー
- Visual Basic
- エクセルVBAでの画像ファイル名取得他
VBAについての質問です。 http://hp.vector.co.jp/authors/VA033788/kowaza.html#0158 上記をベースに、なんとかVBAを下記のように書き換えました。 Sub LoadPictures3() Dim Fnames As Variant Dim Fn As Variant Dim i As Integer Dim Pic As Picture Dim R As Range Dim R2 As Range Dim Pc As Integer Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True) If TypeName(Fnames) = "Boolean" Then Exit Sub Application.ScreenUpdating = False '一枚目の貼付け位置 Set R = Range("B5") Set R2 = R.Offset(35) Pc = 0 For i = 1 To UBound(Fnames) Set Pic = ActiveSheet.Pictures.Insert(Fnames(i)) Select Case (i - 1) Mod 4 + 1 Case 1 Pc = Pc + 1 If Pc >= 2 Then ActiveSheet.HPageBreaks.Add R2 End If With R Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 2 With R.Offset(0, 6) '一枚目に対する二枚目の相対位置 Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 3 With R.Offset(18, 0) Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 4 With R.Offset(18, 6) Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With '次ページの相対位置 Set R = R.Offset(39) End Select Next Application.ScreenUpdating = True End Sub ここで、画像の上の位置(B5のセル位置の画像の場合、B4)に 元々の画像ファイル名を取得し、表記させたいのですが 調べた所、multiselect:=Trueで複数ファイルを選択するときに 画像名が図1、図2に変わっているようで、どうしていいかわかりません。 後、画像を300×225の「変倍」画像にしたいのですが どのようにすれば可能でしょうか? 全くVBAの知識がなく、上のURLを参考に、単語を調べつつ書き換えている状態で、変数やらなんやらの指定・書き方等わかりません。 どなたかご教授願います。
- ベストアンサー
- オフィス系ソフト
- Excel VBAフォーム 登録ボタンの作成方法
いつもお世話になっています。 初めて、Excelのフォームで入力画面を作りました。 複数の項目があって、それを最後に[登録]ボタンをクリックで 表に入れたいのですが、一度にまとめて実行する方法が分かりません。 アドバイスよろしくお願いいたします。 Private Sub cmd_1() Dim i As String If man.Value = True Then ActiveCell = man.Caption End If If woman.Value = True Then ActiveCell = woman.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_2() Dim i As String If man.Value = True Then ActiveCell = Yes.Caption End If If woman.Value = True Then ActiveCell = No.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_downlist() Dim ListNo As Long ListNo = group.ListIndex ActiveCell.Value = group.List(ListNo, i) ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_comment() ActiveCell = comment.Text ActiveCell.Offset(1, -3).Select End Sub
- 締切済み
- Visual Basic
- フォルダー内のファイルのリンク VBA
以前、カーソールを置いた部分のテキストとフォルダーの中にあるファイルが一致した場合、 ボタンを押す事によりハイパーリンクを付けるVBAを教えて頂き、現在も活用をさせて頂いています。 今までエクセル「E」列を対象にしていたのですが、 使用しているうちに前列に項目を入れたくなり「E」列の前に2列追加し、 対象の列が「E」列から「G」列の変更になりました。 それから新たにリンクを作成しようとしても実行出来なくなりました。 追加した前列を消しても駄目に。 素人なりに列を指定しているところを変えてみたのですが駄目でして。 If .Column <> 5 Or .Value = "" Then Exit Subを If .Column <> 7 Or .Value = "" Then Exit Subに。 列を変えた場合は、何処をどうすれば良いのでしょうか? 申し訳ありませんが、教えて頂けないでしょうか? 元のVBA Sub Test() Dim fName As String fName = ThisWorkbook.path & "\test\test-a\" With ActiveCell If .Column <> 5 Or .Value = "" Then Exit Sub fName = fName & .Offset(0, -4).MergeArea.Cells(1, 1).Value & _ "\" & .Value & ".prt" If Dir(fName) <> "" Then ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=fName End If End With End Sub
- ベストアンサー
- その他MS Office製品
- エクセルで行を非表示にするとアクティブなセルが・・・
エクセルで行を非表示にするとアクティブなセル?行?がどこかわからなくなり、マクロでアクティブなセルを移動するときにエラーが出ます。 Sub example() ActiveSheet.Range("D3").Select Do Until ActiveCell = 23 If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select ElseIf ActiveCell <> "" Then ActiveCell.Offset(1, -3).Select ElseIf ActiveCell <> "" Then ActiveCell.Offset(1, -6).Select Else: ActiveCell.EntireRow.Select Selection.EntireRow.Hidden = True ActiveCell.Offset(0, -6).Select End If Loop End Sub 一番下のActiveCell.Offset(0, -6).Select にエラーが出るのですが、どうすればセルを移動できるでしょうか?
- ベストアンサー
- オフィス系ソフト
- エクセルの画像リンク解除
Pictures.Insert で書かれた内容を Shapes.AddPicture の構文に変更したいのですが、 VBAの知識が乏しいので、なかなかうまくいきません。 どなたかわかる方はいらっしゃいますでしょうか? 宜しくお願いします。 Sub Test() Range("B3").Select Dim fName, pict As Picture fName = Application.GetOpenFilename("JPG, *.jpg", MultiSelect:=True) If IsArray(fName) Then For i = 1 To UBound(fName) Set pict = ActiveSheet.Pictures.Insert(fName(i)) pict.TopLeftCell = ActiveCell pict.Width = ActiveCell.Width * 2 pict.Height = ActiveCell.Height * 6 ActiveCell.Offset(7, 0).Activate Next i End If End Sub
- ベストアンサー
- Excel(エクセル)
- エクセルxpのVBA
VBA初心者です。下記を実行すると、「elseに対応するifがありません」と出ます。なぜかわからず困っています。 For hiniti = DateSerial(Range("A3"), Range("A4"), 21) To DateAdd("m", 1, DateSerial(Range("A3"), Range("a4"), 20)) ActiveCell.Value = hiniti ActiveCell.Offset(0, 1).Select If ActiveCell.Column = 7 Then ActiveCell.Offset(1, -7).Select Else: ActiveCell.Offset(0, 1).Select End If next end sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAで無限ループ
教えてください。 以下の2つのエクセルマクロはまったく同じことをさせようとしているのですが、test02の方は.Offset(1).Activateが働かないのか、無限ループに陥ってしまいます。 単にActiveCell.という記述をWith~End Withでまとめただけなのになぜこうなるのでしょうか? Sub test01() ActiveSheet.Cells(1, 1).Activate Do While ActiveCell.Value <> "" If Not IsNumeric(ActiveCell.Value) Then ActiveCell.Offset(0, 1).Value = "文字" ElseIf ActiveCell.Value > 0 Then ActiveCell.Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then ActiveCell.Offset(0, 1).Value = "負数" Else ActiveCell.Offset(0, 1).Value = "その他" End If ActiveCell.Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End Sub Sub test02() ActiveSheet.Cells(1, 1).Activate With ActiveCell Do While .Value <> "" If Not IsNumeric(.Value) Then .Offset(0, 1).Value = "文字" ElseIf .Value > 0 Then .Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then .Offset(0, 1).Value = "負数" Else .Offset(0, 1).Value = "その他" End If .Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End With End Sub
- ベストアンサー
- オフィス系ソフト
- vbaで複数のパターンのファイル名を読み込みたい
例えば、11.jpg~79.jpgの画像を読み込むとします。 これをvbaで記述すると j & i & ".jpg" となります(1の位と10の位の数字は独立していると考えてください) これを、1-1.jpg~7-9.jpg といった形式をvbaで記述すると、 j & "-"& i & ".jpg" となります。 これをvbaで記述させるときに、これをA1のセルに「ji」や、「j-i」や、「i」、「j」と入力させたときに様々なパターンに対応させたいと考えております。 (他の方法でもいいです。やりたいことは、複数パターンのファイル名に対応させたいという事です。) いちいち、写真のファイル名のパターンが違うたびにコード書き直すのも面倒ですし、プログラムわからない人には読み込ませることすらできないです。 4パターンだったら、if文で分けちゃえば?という人もいるでしょうが、それは最終手段として残しておきたいです(プログラムがえらい長くなり、後々の修正が大変だし、パターンが増えるたび追加しなければならないので) せめて、C言語のように#defineによる置き換えができれば、 #define PATARN j & "-"& i として、「一か所のみ修正すれば楽ちん」みたいなことができればいいんですけれども、 VBAで、C言語の#defineに該当するものが何かよくわかりません。 (プログラム本文にはPATARNに該当する箇所が何か所かあるので、修正が大変なんです) もし必要ならと思い、ソースの一部を書いておきます(主要なところだけ残して、後はざっくり削除しています) やってることは、写真を挿入して、規則的に並べて、JPEG変換しています (下のコードは写真の挿入のみ) Sub 写真挿入→JPEG変換() On Error Resume Next Dim flag As Integer Dim xoffset As Integer Dim yoffset As Integer Dim Ystart As Integer Dim i As Integer Dim j As Integer Dim Xstart As Integer Dim str As String Dim Er As String Xstart = 1 Dim Xend As Integer Dim Yend As Integer flag = 0 xoffset = 1 yoffset = 1 Ystart = 1 Yend = 6 Xend = 6 Application.ScreenUpdating = False For j = Xstart To Xend For i = Ystart To Yend ActiveSheet.Pictures.Insert(ActiveWorkbook.Path & _ j & i & ".jpg").Select If i = Yend Then Else If flag = 0 Then ActiveCell.Offset(yoffset, 0).Range("A1").Select ElseIf flag = 1 Then ActiveCell.Offset(0, xoffset).Range("A1").Select End If End If Next If flag = 0 Then ActiveCell.Offset(-(Yend - Ystart) * yoffset, xoffset).Range("A1").Select ElseIf flag = 1 Then ActiveCell.Offset(yoffset, -(Yend - Ystart) * xoffset).Range("A1").Select End If Next Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
お礼
まさに望み通りのことができました。 ありがとうございました。