こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

初心者です。お願いします!!

はじめまして。真紀といいます。
ここ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の部分がいけないと思うのですが、拡張子が付いてるなまえだからいけないのかな?;;
よろしくお願いします><

投稿日時 - 2007-06-14 11:33:43

QNo.3083594

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.3

>しかし、残念ながらうまく動きません・・・;;

先に提示された条件(”写真の名前ーTHD” と ”写真の名前ーSN”を検索)とは検索するデータが異なっているからです。
他の文字は付かない前提でマクロを作成してあるので、提示された条件での動作しか想定していませんので・・・。

今回の補足では[.1000]が付加されているのでマクロを修正しないと検索出来ません。

Fline = Application.WorksheetFunction.Match(fname & "-SN.1000", Worksheets("sheet2").Range("A1:A100"), 0)
のように修正して見て下さい。

[.1000]の部分が変化している(固定ではない)ならこのマクロでは対応出来ませんし、必要な情報を提示して頂かない限り、提示された条件内でしかマクロを書く事は出来ません。

投稿日時 - 2007-06-14 22:56:26

ANo.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

投稿日時 - 2007-06-14 13:47:43

補足

遅くなってすみません。
ご丁寧な対応ありがとうございます。

しかし、残念ながらうまく動きません・・・;;
検索して、拾っているのかどうかもわかりません。

見つかった行番号からデータを取得とありますが、
たとえば、
PIC.bmp を貼り付け、
シート2は
PIC-THD.1000(12.1)
PIC-SN.1000 (13.1)
というのが分かったとしたときに、
結果(得たい数値)は必ず(12.2)と(13.2)にあります。

わがままですみません・・・

投稿日時 - 2007-06-14 18:10:37

ANo.1

>シート1の(i,1)に写真を貼り付けると、

貼付ける写真は1回に1枚なのですか?
複数枚の貼付け(選択)にも対応するのですか?(同じ位置に貼付くので重なって仕舞います。)

>afile-THDの部分がいけないと思うのですが、

名前の探し方が全く違っていますね。
見つかった名前の左から9文字(Len("afile-THD")=9)切り出して"afile-THD"という文字と比較しているだけの処理なので、貼付けたファイル名で比較できていません。

投稿日時 - 2007-06-14 12:09:37

補足

こんなボロボロのプログラムに解凍していただきまして、本当にありがとうございます。

写真は1枚のみです。

もう少し細かく話しますと、シート1に貼り付けた写真の名前に
”写真の名前ーTHD” と ”写真の名前ーSN”
という似たような文字がシート2にあり、
それぞれを任意の場所に張り付けたいのですが、
似ているので、区別のつけ方とかが分からず、afile+”-THD”という物を探すようにしたいのですが、全然わかりません。。。

初心者でほんとにすみません。
プログラムのほとんどはホームページからとかの引用です。 

投稿日時 - 2007-06-14 12:12:07

あなたにオススメの質問