ＶＢＡの記述で、あるシートを別ファイルにした場合

質問

エクセル2002で、商品を管理しています。
１列目に品番をいれると、２列目に品名が表示するようにし、
新規の品番は品名を入れると、追加登録されるようにＶＢＡを組みました。
今度、このシート"商品"を別ファイル(商品.xls)にしたいと思うのですが、
どうしても、やり方が分かりません。
よろしくお願いします。

Public Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim 品番 As String
Dim 品名 As String
Dim i As Long

With Target
If .Column = 1 Then
品番 = .Text
For i = 1 To 65536

If Sheets("商品").Cells(i, 1) = "" Then
ActiveSheet.Cells(.Row, 2) = ""
Exit For
ElseIf 品番 = Sheets("商品").Cells(i, 1) Then
ActiveSheet.Cells(.Row, 2) = Sheets("商品").Cells(i, 2)
Exit For
End If
Next i
End If
If .Column = 2 Then
品名 = .Text
品番 = ActiveSheet.Cells(.Row, 1)

If 品名 = "" Or 品番 = "" Then
Else
For i = 1 To 65536

If Sheets("商品").Cells(i, 1) = "" Then
Sheets("商品").Cells(i, 1) = 品番
Sheets("商品").Cells(i, 2) = 品名
Exit For

ElseIf 品番 = Sheets("商品").Cells(i, 1) Then
Exit For
End If
Next i
End If
End If
End With
End Sub

回答No.6

kazuhiko5681 · ベストアンサー

補足に対するお手数をおかけいたしました。早速サンプルマクロを作ってみました。以下のように操作してみて下さい。

１.商品台帳.xlsというブックと商品コードというブックを新規に作る。それぞれのブックのシート１のＡ１にコード・Ｂ１に商品名と入力する。
２.商品台帳.xlsのＶＢＥ画面を開き、VBEProjectの下にあるThisWorkbookをダブルクリックしてThisWorkbookのコードエディターを開く。
３.そのコードエディターに下記のコードをコピー・ペーストする。

Private Sub Workbook_Open()

Dim myBook As Workbook
Dim myWbn As String

For Each myBook In Workbooks
myWbn = myBook.Name
If myBook.Name = "商品コード.xls" Then Exit Sub
Next

Workbooks.Open ("C:\My Documents\商品コード.xls")
Workbooks("商品台帳.xls").Activate

End Sub

４.Sheet1のコードエディターを開き、下記のコードをコピー・ペーストをする。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRow As Integer
Dim myWsn As Worksheet
Dim myCell As String
Dim myRange As Range

myRow = Target.Row
If Target.Address = Range("A" & myRow).Address _
Or Target.Address = Range("B" & myRow).Address Then
Set myWsn = Workbooks("商品コード.xls").Worksheets(1)
myCell = myWsn.Range("A1").CurrentRegion.SpecialCells(xlCellTypeLastCell).Address
Set myRange = myWsn.Range("A2:" & myCell).Find(Target.Value, lookat:=xlWhole)
Application.EnableEvents = False
If myRange Is Nothing Then
If Target.Address = Range("A" & myRow).Address Then
myWsn.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Target.Value
Else
myWsn.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = Target.Value
End If
Else
Target.Offset(0, 1).Value = myRange.Offset(0, 1).Value
Target.Offset(0, 1).Columns.EntireColumn.AutoFit
End If
Application.EnableEvents = True
End If

End Sub

あなた様のおやりになりたいことが、できます。

何か不都合なことがありましたら、ご遠慮なくお知らせ下さい。修正サンプルマクロを作りたいと思います。

お礼

問題なく稼動しました。
親切に他Ｂｏｏｋを開くマクロまで作ってもらって、助かります。
ただ、私の勉強不足でと、ＶＢＡ記述のレベルが高いせいか、内容理解には時間がかかりそうです。
当面の改造とかを考え、＃１の方法と合わせて使わせていただきます。
丁寧な回答ありがとうございました。

回答No.5

imogasi

#3の者です。＃４のkazuhikoのさんほか詳しく読んでくだっさったようで、まずお礼を申し上げます。他の方ebisさんのご質問・解答の場ですが一言
言い訳めいたことを述べさせていただきます。
（１）xlＰartのこと
　　Ａ．縦１列の検索と決まっているのでxlPartでも良いか
　　　　と思いました。それにしてはCellsになっていますね　　　　。Range（）にしたかったのですが。
　　Ｂ小数例ながらテストをしており、問題なく動きましたの　　　　でそのままにしました。
　　もう少し詳しい、不適当な理由がわかれば教えてください。
（２）Activateの多用の点
　　私自身気かひけていて、懸念を解答の末尾に書いておりま　　す。今後勉強して今後は改善したいと思います。
　　オブジェクト宣言方式？では危ないと過去の経験から推定して、解答の締め　　きられる時間を気にして、その方式でテストする時間が取れな　　いと、取りあえず載せました。別のブックの場合も、
　　ＷＢ（１）．ＷＳ（２）．Ｒａｎｇｅ（３）で１の部分に
　　Ｂｏｏｋ名を指定して（単一Ｂｏｏｋの場合と同じく）参　　照出来ればといつも思いますが、（今回別ブックの参照でてこずり、エラーがでて）うまくいかないケースが多いので諦めました。勉強不足と資料不足で、根本のところが迷いがあり、小生の弱点と心得ております。今後とも宜しく。

回答No.4

kazuhiko5681

＃Ｎｏ３のご回答で気になる点がありましたので、生意気ながら意見を述べさせていただきます。

１.Findメソッドで、引数のLook AtにXlpartを指定しておりますが、これでは、私が以前Findメソッドを使ってこの方法で検索をかけた結果、うまく検索ができなかったことがあります。この場合、必ずlook Atには、xlwholeを指定するべきかと思います。
２.処理するときに対象となるブックをいちいちアクティブにしているようですが、変数を２個worksheet型で宣言し、その変数にそれぞれのブックのシート名を代入すれば、もっと簡単になるのではないでしょうか。

以上気がついて点を生意気ながら書かせていただきました。

回答No.3

imogasi

（１）Booka.xlsのSheet1にＡ１：Ｂ１０に
コード 商品名
1 ノートＡ４
2 定規
4 鉛筆
5 消しゴム
6 挟み
7 マーカー
9 ボールペン
10 糊
12 ナイフ
をテストで作りました。
（２）Bookb.xlsを作り保存する。
（３）Bookb.xlsを開き、そのModule1に
Sub test02()
Workbooks.Open ("c:\My Documents\Booka.xls")
End Sub
を作る。そして実行しBooka.xlsを開いておく。
－－－－－
Bookb.xlsを開いているところで
もう一つModule1に
Private Sub Worksheet_Change(ByVal Target As Range)
Dim z As Object
'MsgBox Target
r = Target.Row
c = Target.Column
If c = 1 Then
Windows("booka.xls").Activate
Set z = ActiveWorkbook.Worksheets("Sheet1").Cells.Find(What:=Target, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
' If z Is Nothing Then
' MsgBox "コード無し"
' Exit Sub
' End If
x = z.Offset(0, 1)
Windows("bookb.xls").Activate
ActiveWorkbook.Worksheets("Sheet1").Cells(r, c + 1) = x
Else
End If
End Sub
異なるＢｏｏｋを参照するため行き来するのに、Ａｃｔｉｖａｔｅを多用していますが、何か別の方法があるような気がする
が取りあえず載せます。小数例でテスト済み。
またオフコードの入力に対しての備えやＤＥＬやその他多用な
入力に対する対処が考えらていません。あとは宜しく。

お礼

テストさせていただきました。
検索については、はうまく動作しました。
ちょっと画面がちらつきますが。
ありがとうございました。

回答No.2

kazuhiko5681

はじめまして。

１.現在１つのブック(ブックＡとする)に２つのシート(商品を管理するシートと品番と品名のみを記入したシート)がある。
２.今度、品番と品名のみを記入したシートを別ブック(ブックＢとする)に移動する。
３.商品を管理するシートのＡ列に品番を入力したとき、入力された品番をブックＢの中から探し、見つかった品番に対応する品名をブックＡの品番の右隣に自動で表示させる。
４.もしブックＡに入力した品番がブックＢになかったら、ブックＢの品番が書かれている最後のセル番地のすぐ下へ入力させ、その品番に対応する品名をその右隣に入力させる。
あなた様のやられたいことはこのようなことでよろしいのでしょうか。
もし、ちがうのであれば、あなた様のおやりになりたいことを上の要領でお知らせ下さい。
私でよろしければ、サンプルマクロを作ってみたいと思います。
お手数をおかけいたしますが、よろしくお願いいたします。

補足

遅れてすみません。
全て、おっしゃられている通りです。
よろしくお願い致します。

回答No.1

nishi6

下の様に修正してみました。
最初の4行を追加。コード内の『Sheets("商品")』を『ws2』に変更しました。
最初の4行で参照・修正するシートを変数ws2に割り当てています。
そのため、コードの意味合いは変更していません。ブック商品は開いてある前提です。

Public → Private にしています。
検索の方法としては、For～Next　とは別に、Findを使う方法もあります。

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
　　Dim wb2 As Workbook 'ブック商品
　　Dim ws2 As Worksheet 'ブック商品のシート商品
　　　　Set wb2 = Workbooks("商品.xls")
　　　　Set ws2 = wb2.Worksheets("商品")

　　Dim 品番 As String
　　Dim 品名 As String
　　Dim i As Long

　　With Target
　　　　If .Column = 1 Then
　　　　　　品番 = .Text
　　　　　　For i = 1 To 65536
　　　　　　　　If ws2.Cells(i, 1) = "" Then
　　　　　　　　　　ActiveSheet.Cells(.Row, 2) = ""
　　　　　　　　　　Exit For
　　　　　　　　ElseIf 品番 = ws2.Cells(i, 1) Then
　　　　　　　　　　ActiveSheet.Cells(.Row, 2) = ws2.Cells(i, 2)
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next i
　　　　End If
　　　　If .Column = 2 Then
　　　　　　品名 = .Text
　　　　　　品番 = ActiveSheet.Cells(.Row, 1)

　　　　　　If 品名 = "" Or 品番 = "" Then

　　　　　　Else
　　　　　　　　For i = 1 To 65536
　　　　　　　　　　If ws2.Cells(i, 1) = "" Then
　　　　　　　　　　　　ws2.Cells(i, 1) = 品番
　　　　　　　　　　　　ws2.Cells(i, 2) = 品名
　　　　　　　　　　　　Exit For
　　　　　　　　　　ElseIf 品番 = ws2.Cells(i, 1) Then
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　End If
　　　　End If
　　End With
End Sub

お礼

やはり他Bookを開く方法しかないようですね。
＃６の方法と合わせて使わせていただき、うまく稼動しました。
ありがとうございました。

補足

遅れてすみません。
回答ありがとうございます。
できれば、商品.xlsを開かずに実現できないものでしょうか。