はじめまして。真紀といいます。
ここ1月くらい悩みましたが、まったく答えがわからず、答えの探し方もわかりません。
どうか、このプログラムだけ、完成させてください.お願いします;;
シート1の(i,1)に写真を貼り付けると、サイズを補正して張り付き、
シート2の中から、シート1と同じ名前が付いているものを(i,1)から探して、見つけたらその2行目に書いてある数値を任意のセルに入力する。
このプログラムをいろんな人のホームページから探して書いたのですが、どうしても写真と同じ『名前』が分かりません。
教えてください><。。。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim selectRowNo As Long
Dim afile As Variant
Dim i As Long
Select Case Target.Column
Case 1
selectRowNo = Target.Row
Worksheets("sheet1").Activate
Worksheets("sheet1").Cells(selectRowNo, 1).Select
afile = Application.GetOpenFilename("bmpファイル (*.bmp), *.bmp", , , , True)
If IsArray(afile) Then
ActiveSheet.Pictures.Insert(afile).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 235.5
Selection.ShapeRange.Width = 385.5
End If
For i = 1 To 100
If Worksheets("sheet2").Cells(i, 1) = "" Then
Else
If Left(Worksheets("sheet2").Cells(i,1), Len("afile-THD")) = "afile-THD" Then
Worksheets("sheet1").Cells(Target.Row + 7, 11) = Worksheets("sheet2).Cells(i, 2)
Exit For
End If
End If
Next
以上ですが、bmpは気にしないでください。
afile-THDの部分がいけないと思うのですが、拡張子が付いてるなまえだからいけないのかな?;;
よろしくお願いします><
A 回答 (3件)
- 最新から表示
- 回答順に表示
No.3
- 回答日時:
>しかし、残念ながらうまく動きません・・・;;
先に提示された条件(”写真の名前ーTHD” と ”写真の名前ーSN”を検索)とは検索するデータが異なっているからです。
他の文字は付かない前提でマクロを作成してあるので、提示された条件での動作しか想定していませんので・・・。
今回の補足では[.1000]が付加されているのでマクロを修正しないと検索出来ません。
Fline = Application.WorksheetFunction.Match(fname & "-SN.1000", Worksheets("sheet2").Range("A1:A100"), 0)
のように修正して見て下さい。
[.1000]の部分が変化している(固定ではない)ならこのマクロでは対応出来ませんし、必要な情報を提示して頂かない限り、提示された条件内でしかマクロを書く事は出来ません。
No.2
- 回答日時:
実際の動作テストはしていませんが、こんな感じでいかがでしょうか?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim afile As Variant
Dim fname As String
Dim find1 As String
Dim find2 As String
Dim Fline As Long
If Target.Column = 1 Then
Worksheets("sheet1").Activate
afile = Application.GetOpenFilename("bmpファイル (*.bmp), *.bmp", , , , False)
If afile <> False Then
ActiveSheet.Pictures.Insert(afile).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 235.5
Selection.ShapeRange.Width = 385.5
' "C:\xxxxxx\zzzzzz\PIC.bmp" の文字からファイル名("PIC")だけを取出す。
fname = Mid(afile, InStrRev(afile, "\") + 1, InStrRev(afile, ".") - InStrRev(afile, "\") - 1)
On Error Resume Next 'エラーを無視する。
'ワークシート関数(MATCH)を使って一致データを探す。
Fline = Application.WorksheetFunction.Match(fname & "-SN", Worksheets("sheet2").Range("A1:A100"), 0)
'見つかった行番号からデータを取得。
find1 = Worksheets("sheet2").Cells(Fline, 1)
Fline = Application.WorksheetFunction.Match(fname & "-THD", Worksheets("sheet2").Range("A1:A100"), 0)
find2 = Worksheets("sheet2").Cells(Fline, 1)
Cells(Target.Row + 7, 11) = find1 '"-SN" の結果
Cells(Target.Row + 7, 12) = find2 '"-THD"の結果
End If
End If
End Sub
この回答への補足
遅くなってすみません。
ご丁寧な対応ありがとうございます。
しかし、残念ながらうまく動きません・・・;;
検索して、拾っているのかどうかもわかりません。
見つかった行番号からデータを取得とありますが、
たとえば、
PIC.bmp を貼り付け、
シート2は
PIC-THD.1000(12.1)
PIC-SN.1000 (13.1)
というのが分かったとしたときに、
結果(得たい数値)は必ず(12.2)と(13.2)にあります。
わがままですみません・・・
No.1
- 回答日時:
>シート1の(i,1)に写真を貼り付けると、
貼付ける写真は1回に1枚なのですか?
複数枚の貼付け(選択)にも対応するのですか?(同じ位置に貼付くので重なって仕舞います。)
>afile-THDの部分がいけないと思うのですが、
名前の探し方が全く違っていますね。
見つかった名前の左から9文字(Len("afile-THD")=9)切り出して"afile-THD"という文字と比較しているだけの処理なので、貼付けたファイル名で比較できていません。
この回答への補足
こんなボロボロのプログラムに解凍していただきまして、本当にありがとうございます。
写真は1枚のみです。
もう少し細かく話しますと、シート1に貼り付けた写真の名前に
”写真の名前ーTHD” と ”写真の名前ーSN”
という似たような文字がシート2にあり、
それぞれを任意の場所に張り付けたいのですが、
似ているので、区別のつけ方とかが分からず、afile+”-THD”という物を探すようにしたいのですが、全然わかりません。。。
初心者でほんとにすみません。
プログラムのほとんどはホームページからとかの引用です。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Visual Basic(VBA) VBAコードが作動せず、どこに問題があるのか教えて下さい。 3 2023/06/13 13:20
- Visual Basic(VBA) 【Excel VBA】自動メール送信の機能追加 5 2022/09/29 12:53
- Visual Basic(VBA) 【変更】ファイルを閉じてダイアログで保存した時、更新したシートだけの処理の実行をする 5 2022/03/26 18:31
- Visual Basic(VBA) いつもお世話になっております、VBAで教えて頂きたいのですが 2 2022/05/05 22:20
- Visual Basic(VBA) VBAで質問ですが、皆さんはどの様に導き出しているのでしょうか? 6 2022/05/03 21:53
- Visual Basic(VBA) excel vbaでvlooupの変数がわかりません。 7 2022/05/30 09:35
- Excel(エクセル) エクセルVBAでオブジェクトが必要です 2 2022/09/10 16:37
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルの表示形式を保ったま...
-
Excel VBA For Each Next構文...
-
Excel VBAのComboboxのRemoveItem
-
excelのマクロでrangeの選択が...
-
Excel2000 VBA ダブルクリック...
-
EXCELで2つの数値のうち大きい...
-
エクセルで二つの数字の小さい...
-
PowerPointで表の1つの列だけ...
-
エクセルで時刻(8:00~20:00)...
-
Excelで隣のセルと同じ内容に列...
-
SUMIFとCOUNTIFを合わせたよう...
-
エクセルで、2種類のデータを...
-
エクセルでオートフィルタのボ...
-
VBAで文字列を数値に変換したい
-
エクセル 同じ値を探して隣の...
-
Excel関数:「0」を除いた標準...
-
エクセルでの複数条件下での標...
-
エクセルで最初のスペースまで...
-
エクセル初心者です 関数の入れ...
-
ある一定時間を超えた場合の超...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルの表示形式を保ったま...
-
excelのマクロでrangeの選択が...
-
エクセル 1つのセル毎に入力...
-
Excel VBA For Each Next構文...
-
Excel2000 VBA ダブルクリック...
-
Excel VBAのComboboxのRemoveItem
-
Gメールの内容をスプレッドシ...
-
エクセルのIF関数がうまくいき...
-
EXCEL(エクセル)で0.001以下...
-
エクセルで重複するセルを削除...
-
エクセルの関数を連続コピー
-
EXCELで2つの数値のうち大きい...
-
Excelで隣のセルと同じ内容に列...
-
エクセルで二つの数字の小さい...
-
PowerPointで表の1つの列だけ...
-
エクセルで、2種類のデータを...
-
エクセルで最初のスペースまで...
-
エクセルでオートフィルタのボ...
-
エクセルのオートフィルタで最...
-
エクセルで時刻(8:00~20:00)...
おすすめ情報