関数 ｏｒ マクロ（エクセル）

質問

行の項目と列の項目を検索して重なる部分のデータを拾いたいのですがどうもうまくいきません。初歩的なことかもしれませんが、VLOOKUPとHLOOKUP関数をあわせたようなもの。LOOKUPウィザードでもやってみるのですがうまくいかないのでよろしくお願いします。（最終的にVBAでやりたいです）

元のデータは、（Sheet3）にあって（Sheet2）で項目を並べ縦と横の項目に一致するデータを持ってきたいです。
Sheet3にあるデータは、別のブックよりVBAで検索したデータを持ってきています。

また、Sheet1、2ともその都度行数（検索項目数）が変わるので、できればデータシートの行数にあわせて行きたいのですが・・・こうなるとVBAになると思い挑戦しているのですがこれがまたうまくいきません。
で、データの行数にあわせて拾い出し、A列で最終行を検索して、Ｌ列～Ｗ列の各列の3行目に、5行目～最終行までの合計を取ろうと思っています。

説明が下手ですみませんが、よろしくお願いします。

環境：Win2000、98　Office2000です。

回答No.5

papayuka · ベストアンサー

こんにちは。

> cSheet(data)は、C3を基点とし、Y3(固定)までの横の項目と縦は可変(商品コード)です。

とありますが、変更されたソースから判断し C2～Y2 までは項目行だと
解釈します。

.Cells(mRow, mCol) = "=Vlookup(" & .Cells(mRow, 4).Address & _
"," & cAddress & "," & List(mCol - 5) - 2 & ",0)"

これだとどうでしょうか？
以下、変更部分について一応解説します。

.Cells(mRow,1) → .Cells(mRow,4)

1はA列、4はD列です。D列基点ではこうしないとダメです。

List(mCol - 2) → List(mCol - 5) - 2

List配列には、タイトル項目が同じ場合の列番号が入ります。R1C1形式で
表示した場合、A列は1、B列は2、...

配列は、0から始まりますので、元の例では mCol（列番号） が 2の時に
mCol - 2 = 0 を指すようにしてます。
今回は、最初のmColが E(5)列なので、 mCol - 5 にする必要があります。

つまり、E、F、G、H、Y と5個の値を収めた場合、配列の有効Index は0～4の
5個です。List(0) には、E列を表す 5 が入り、List(4)には Y列を表す 25が
入ります。

一方、mCol はループする為の列番号ですので、D(5)列からスタートして、5回
ループしたとすると元のままでは、

List(5 - 2) = List(3)
List(6 - 2) = List(4)
List(7 - 2) = List(5)　← ここで インデックスが範囲を超えます。
List(8 - 2) = List(6)
List(9 - 2) = List(7)

また、配列に収めたのは列番号なので、Dataシートの最初の列とSheet2の
最初の列が、ずれた分を補う為に -2 としています。

VBE画面で、表示－イミディエイトウィンドウを表示して下記部分に
Debug.Print を追加すると、配列に収めた列番号がわかります。

For Each r1 In pRange
　For Each r2 In cRange
　　If r1 = r2 Then
　　　List(cnt) = r2.Column
　　　Debug.Print r2.Column　　'これを追加
　　　Exit For
　　End If
　Next r2
　cnt = cnt + 1
Next r1

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
ここに Debug.Print を追加するとセルに入れた VLookup関数 が解かります。

For mCol = 5 To .Range("D5").End(xlToRight).Column
　.Cells(mRow, mCol) = "=Vlookup(" & .Cells(mRow, 4).Address & _
　　　　　　　　"," & cAddress & "," & List(mCol - 5) - 2 & ",0)"

　'↓これを追加
　Debug.Print "=Vlookup(" & .Cells(mRow, 4).Address & _
　　　　　　　"," & cAddress & "," & List(mCol - 5) - 2 & ",0)"

　.Cells(mRow, mCol) = .Cells(mRow, mCol)
Next mCol

エラーの場合と、修正した場合、比べてみると解かりやすいでしょう。

お礼

本当にご丁寧にありがとうござしました。

回答No.4

imogasi

他の方の回答プログラムは精緻で複雑です。
私のは簡単で短いを旨とし、変数の宣言も略してＧｏＴｏ文もあり幼稚ですが、どちらを採りますか。
－－－－－
条件：第１行目は項目見だしとする
Ｓｈｅｅｔ３はＡ列でソートしておくこと。（ＶＢＡでも出来ますが。）
　　　　Ｓｈｅｅｔ２はＡ列でソートしておくこと。（同上）
Ｓｈeｅｔ２には同じキーは現われないものとする。
　　　　目視により、Ｓｈｅｅｔ３第２列－－＞Ｓｈｅｅｔ２第２列にセット
　　　　　　　　　　　Ｓｈｅｅｔ３第３列－－＞Ｓｈｅｅｔ２第３列にセット
　　　　　　　　　　　Ｓｈｅｅｔ３第６列－－＞Ｓｈｅｅｔ２第４列にセット・・・・・
　　　　をメモしておくこと。　
　　　自動的にＳｈｅｅｔ２の項目名（漢字）をＳｈｅｅｔ３で探して、
　　　データを取ってくることも出きるが、複雑になるので避けます。
－－－－－－
Sub test01()
a = Worksheets("sheet3").Range("a2").CurrentRegion.Rows.Count
b = Worksheets("sheet2").Range("a2").CurrentRegion.Rows.Count
j = 2
i = 2
'----
p01:
'-----終わり判定
If i > a+1 Then GoTo p02
If j > b+1 Then GoTo p02
'----Ｓｈｅｅｔ２のキーとＳｈｅｅｔ３のキーの比較をする
'----一致する時Ｓｈｅｅｔ３へＳｈｈｅｔ２より項目データ値をセット
If Worksheets("sheet3").Cells(i, 1) = Worksheets("sheet2").Cells(j, 1) Then
Worksheets("sheet2").Cells(j, 2) = Worksheets("sheet3").Cells(i, 2)
Worksheets("sheet2").Cells(j, 3) = Worksheets("sheet3").Cells(i, 3)
Worksheets("sheet2").Cells(j, 4) = Worksheets("sheet3").Cells(i, 6)
'---
i = i + 1 'マスターとトランザクションを進める
j = j + 1
Else
'---一致しない時
i = i + 1 'マスターだけを進める
End If
GoTo p01
'---終了
p02:
End Sub
マスターはＳｈeｅｔ３,トランザクションはＳｈｅｅｔ２
です。「進める」とはポインターのi,jを＋１して、下の
行を見ると言うこと。

お礼

ありがとうございます。シンプルで良いですね！

回答No.3

papayuka

先の回答でも半分は出来てると思いますが、詳しい内容から判断し、
処理速度を重視して下記のようにしました。新規ブックを作り試して
下さい。

前提条件
シート名 DataSheet のセル A1 から列方向にタイトル行がある。
シート名 DataSheet のセル A2 から行方向に１つ以上のデータがある。
シート名 Sheet2 のセル A2 から移すためのタイトル行がある。
シート名 Sheet2 のセル A2 からのタイトル行で A2～C2は集計項目
ではない。例）A2=商品CD、B2=商品名、C2=単価、D2～ 月別集計列
シート名 Sheet2 のセル A3 以降に検索用データが１つ以上ある。
上記のタイトル列とデータ行は、途中に空白セルがない。

'---------------------------------------------------------------
Sub Test2()
'対象のシート名を指定（cSheetはコピー元、pSheetはペースト先）
Const cSheet = "DataSheet"
Const pSheet = "Sheet2"
'変数宣言
Dim List, cRange As Range, pRange As Range
Dim r1 As Range, r2 As Range, cnt As Integer
Dim cAddress As String, mRow As Long, mCol As Integer

'速度アップの為、画面を止める
Application.ScreenUpdating = False
'エラーの場合 ERR へ飛ぶ
On Error GoTo ERR
'コピーシートのタイトル行を判定
With Worksheets(cSheet)
　Set cRange = .Range("B1:" & _
　　　.Range("B1").End(xlToRight).Address)
End With
'ペーストシートのタイトル行を判定
With Worksheets(pSheet)
　Set pRange = .Range("B2:" & _
　　　.Range("B2").End(xlToRight).Address)
End With
'ペーストシートの必要数で配列の要素数を確定
ReDim List(pRange.Count - 1)
'ペーストシートの項目とコピーシートの項目が同じ
'時にコピーシートの項目列番号を配列に格納
cnt = 0
　For Each r1 In pRange
　　For Each r2 In cRange
　　　　If r1 = r2 Then
　　　　　　List(cnt) = r2.Column
　　　　　　Exit For
　　　　End If
　　Next r2
　　　cnt = cnt + 1
　Next r1
'コピーシートのVLOOKUP用範囲を取得
With Worksheets(cSheet).Range("A1").CurrentRegion
　Set cRange = .Offset(1, 0). _
　　　　　　　Resize(.Rows.Count - 1, .Columns.Count)
　　　cAddress = cSheet & "!" & cRange.Address
End With
'ペーストシートにVLOOKUP関数を代入
'あまり多いと重くなるので、すぐに値に置き換え
With Worksheets(pSheet)
　For mRow = 3 To .Range("A2").End(xlDown).Row
　　For mCol = 2 To .Range("A2").End(xlToRight).Column
　　　　.Cells(mRow, mCol) = "=Vlookup(" & .Cells(mRow, 1).Address & _
　　　　　　　　　　　　　"," & cAddress & "," & List(mCol - 2) & ",0)"
　　　　.Cells(mRow, mCol) = .Cells(mRow, mCol)
　　Next mCol
　Next mRow
End With
'ペーストシートにSUM関数を代入
With Worksheets(pSheet)
　mRow = .Range("A2").End(xlDown).Row
　For mCol = 4 To .Range("A4").End(xlToRight).Column
　　　　.Cells(1, mCol) = "=SUM(" & .Cells(3, mCol).Address & ":" & _
　　　　　　　　　　　　　　Cells(mRow, mCol).Address & ")"
　Next mCol
End With

'不要変数の初期化
Set cRange = Nothing: Set pRange = Nothing
Set r1 = Nothing: Set r2 = Nothing: Set List = Nothing
'正常終了の場合はここで終わる
Exit Sub

ERR:
'エラー時はメッセージを表示し終わる
　MsgBox "エラーの為に実行が中止されました。", _
　　　　　vbCritical + vbOKOnly, "エラー"
End Sub

'---------------------------------------------------------------

VBE画面でソース内の ScreenUpdating を選択しF1キーを押せば、VBA
ヘルプが呼び出せます。VBAヘルプがインストールされてない場合は、
OfficeのCDから追加インストール出来ます。

「初心者」という言葉は免罪符ではありません。ソースにコメント
を加えろと言うのは、自分で調べる事を放棄しているのと同じである
と私は思います。

「ヘルプの意味が解らない」「どうしてこのソースでこういう動きになる
のか解らない」って事はあるでしょう。
自分で調べたうえでの疑問なら、喜んでお答えします。解かる範囲なら。

補足

>「初心者」という言葉は免罪符ではありません。ソースにコメント
>を加えろと言うのは、自分で調べる事を放棄しているのと同じである
>と私は思います。

おっしゃるとおりです。大変失礼致しました。にも関わらずご丁寧な回答ありがとうございました。昨日からがんばって実際のデータに移してコードを書いているところです。
Sub test2（）ではうまくいったのですが、なかなかうまく動いてくれません。
実際のデータは、
cSheet(data)は、C3を基点とし、Y3(固定)までの横の項目と縦は可変(商品コード)です。
pSheetは、D5を基点としR5(固定)までのcSheetから必要な部分だけを抜いた項目と縦は可変(商品コード)です。
どうしても
.Cells(mRow, mCol) = "=Vlookup(" & .Cells(mRow, 1).Address & _
"," & cAddress & "," & List(mCol - 2) & ",0)"
で止まります。→（List（mCol－2）=〈インデックスが有効範囲にありません〉）

どうしてでしょうか？お助けいただけますか？よろしくお願いいたします。

pSheetの項目に1つの日付からとってきた日付の項目があります。
L5以降のセルに、=DATE(YEAR(Sheet1!$E$9),MONTH(Sheet2!$E$9)+0,1)で右へ1月づつ増えて6ヶ月あります。cSheet(data)には1年間の日付の項目があります。毎月1日（2002/5/1・・・）
また、各月の中（縦横とも項目はすべて有）のデータはすべて埋まってはおらず虫食い状態です。
これも問題でしょうか？

↓今書いているコードです。
Sub test2()
Const cSheet = "data"
Const pSheet = "Sheet2"
'変数宣言
Dim List, cRange As Range, pRange As Range
Dim r1 As Range, r2 As Range, cnt As Integer
Dim cAddress As String, mRow As Long, mCol As Integer

Application.ScreenUpdating = False
'On Error GoTo ERR -------------Check 中断-------------------
With Worksheets(cSheet)
Set cRange = .Range("D2:" & _
.Range("D2").End(xlToRight).Address)
End With
With Worksheets(pSheet)
Set pRange = .Range("E5:" & _
.Range("E5").End(xlToRight).Address)
End With

ReDim List(pRange.Count - 1)
cnt = 0
For Each r1 In pRange
For Each r2 In cRange
If r1 = r2 Then
List(cnt) = r2.Column
Exit For
End If
Next r2
cnt = cnt + 1
Next r1
With Worksheets(cSheet).Range("C2").CurrentRegion
Set cRange = .Offset(1, 0). _
Resize(.Rows.Count - 1, .Columns.Count)
cAddress = cSheet & "!" & cRange.Address
End With
With Worksheets(pSheet)
For mRow = 6 To .Range("D5").End(xlDown).Row
For mCol = 5 To .Range("D5").End(xlToRight).Column
.Cells(mRow, mCol) = "=Vlookup(" & .Cells(mRow, 1).Address & _
"," & cAddress & "," & List(mCol - 2) & ",0)"
.Cells(mRow, mCol) = .Cells(mRow, mCol)
Next mCol
Next mRow
End With
'ペーストシートにSUM関数を代入
----------とめています。都合上別シートで集計することにしました。
'With Worksheets(pSheet)
' mRow = .Range("A2").End(xlDown).Row
' For mCol = 4 To .Range("A4").End(xlToRight).Column
' .Cells(1, mCol) = "=SUM(" & .Cells(3, mCol).Address & ":" & _
’ Cells(mRow, mCol).Address & ")"
' Next mCol
'End With

'不要変数の初期化
Set cRange = Nothing: Set pRange = Nothing
Set r1 = Nothing: Set r2 = Nothing: Set List = Nothing
Exit Sub

'ERR: -----------------------とめて動きを見ています-----------------
'MsgBox "エラーの為に実行が中止されました。", _
' vbCritical + vbOKOnly, "エラー"
End Sub

回答No.2

papayuka

こんにちは。

myFind = Cells(myRow, myCol)

ここは、

myFind = ws.Cells(myRow, myCol)

にしないといけませんでした。

補足

質問が悪かったようですみません。
DataSheet（Sheet3）に例えば・・・

商品コード　　商品名　　単価　　5月数量　　4月数量　　　3月数量　　・・・
　123　　　　　　あ　　　　　5　　　　　11　　　　　12　　　　　10
　145　　　　　　い　　　　　7　　　　　15　　　　　17　　　　　14
　167　　　　　　う　　　　　6　　　　　19　　　　　10　　　　　　0
　129　　　　　　え　　　　　5　　　　　14　　　　　19　　　　　13

実際にはもっとたくさんの項目（列）と行数がありますが・・・

これをSheet2の

仮にA列に複数行の商品コードと項目をあらかじめ入力しておき、商品コードに対応する各項目の値をB列以降に並べていきたい。

Sheet2にはあらかじめ商品コードと項目が書いてあり、Sheet3にデータを流した時にそのままSheet2に流れてくるといいです。

結果↓

商品コード　商品名　　単価　　3月数量　　4月数量　　
123　　　　　　あ　　　　　5　　　　　　10　　　　　　12　　　　　
145　　　　　　い　　　　　7　　　　　　14　　　　　　17　
167　　　　　　う　　　　　6　　　　　　　0　　　　　　10

で・・・商品コードのあるA列の最終行を見つけて、各月の数量の合計を項目の上に求めたい。

うまく説目ができなくてすみません。よろしくお願いします。また、VBAはまだ初心者のなでできれば、コードの中に処理をさせている内容を記入していただけると助かります。なかなか、応用ができないもので、お手数ですがよろしくお願いします。

回答No.1

papayuka

こんにちは。
文章だけだと、何をされたいのか解りずらいですね。
ハズしてるかも知れませんが...

Sheet1のA1～D4にこんな表があったとします。

　　　　カメラ　　時計　　指輪
A商店　　2000　　　5000　　8000
B商店　　3000　　　6000　　9000
C商店　　4000　　　7000　　9500

以下のSub Testを実行すると 6000 と表示します。
新規ブックでテストして下さいね。

Sub Test()
　MsgBox myFind("B商店", "時計", "Sheet1")
End Sub

Function myFind(fRow As String, fCol As String, sN As String) As String
Dim ws As Worksheet, myRow As Long, myCol As Integer
Dim rowRange As Range, colRange As Range, r As Range

　On Error GoTo ERR
　Set ws = ThisWorkbook.Worksheets(sN)
　Set rowRange = ws.Range("A2:" & ws.Range("A65536").End(xlUp).Address)
　Set colRange = ws.Range("B1:" & ws.Range("IV1").End(xlToLeft).Address)

　For Each r In rowRange
　　If r.Text = fRow Then
　　　　myRow = r.Row
　　　　Exit For
　　End If
　Next r

　For Each r In colRange
　　If r.Text = fCol Then
　　　　myCol = r.Column
　　　　Exit For
　　End If
　Next r

　myFind = Cells(myRow, myCol)
　Exit Function
ERR:
　myFind = "Not Found"
End Function