VBAで条件が2つある場合の転記について

質問

現在Book1.xlsmでユーザーフォームを作成しています。
ここにComboBox7（日付）、ComboBox8（項目）、TextBox11（数値）を配置しています。コンボボックス やテキストボックスに入力があるとBook1.xlsmのSheet1にそれぞれComboBox7はA2、ComboBox8はB1、TextBox11はB2に入力されるようになっています。

ここで、B2の数値を別なブックBook2.xlsxのSheet2に転記したいと考えております。
Book2.xlsxのSheet2では、A列に日付、B1～AZ1に項目が入っています。

Book1.xlsmのSheet1のA2と同じ日付、B1と同じ項目が交差するところにB2の数値を転記したい場合はどのようにしたら良いのか教えていただけませんでしょうか？

回答No.5

kkkkkm · ベストアンサー

> 転記するのがC2はBook2.xlsxのSheet3、D2はBook2.xlsxのSheet4、
> E2はBook2.xlsxのSheet5と

mDate = Sheets("Sheet1").Range("A2").Value
mItemStr = Sheets("Sheet1").Range("B1").Value
これは変更がないという事で、各シートのA列に日付、B1～AZ1に項目でSheet2と同じという事ですね。

With wb.Worksheets("Sheet2")
から
End With
をシート分コピペして
シート名をそれぞれ変更し

.Cells(mRow, mCol).Value = Sheets("Sheet1").Range("B2").Value

上記の部分(B2)をシートに合わせて変更してもいいと思いますが

ほとんど同じものが並ぶことになり長くなりますから、以下のようにしてはいかがでしょう。
Callの行のシート名とセルの値を適宜変更して下さい。
Function以下は変更しないでください。

Sub Test2()
Dim mDate As Date, mItemStr As String
Dim ex As New Excel.Application
Dim mPath As String
Dim wb As Workbook

mDate = Sheets("Sheet1").Range("A2").Value
mItemStr = Sheets("Sheet1").Range("B1").Value
mPath = "C:\ok\Book2.xlsx"
Set wb = ex.Workbooks.Open(Filename:=mPath)
With Sheets("Sheet1")
Call DataCopy(wb, "Sheet2", mDate, mItemStr, .Range("B2").Value)
Call DataCopy(wb, "Sheet3", mDate, mItemStr, .Range("C2").Value)
Call DataCopy(wb, "Sheet4", mDate, mItemStr, .Range("D2").Value)
Call DataCopy(wb, "Sheet5", mDate, mItemStr, .Range("E2").Value)
End With
Call wb.Save
Call wb.Close
Call ex.Application.Quit
End Sub

Function DataCopy(ByRef wb As Workbook, ByVal ShName As String, ByVal mDate As Date, ByVal mItemStr As String, ByVal mDATA As Variant)
Dim LastRow As Long, mRow As Long, mCol As Long
Dim FRange As Range, flg As Boolean
Dim i As Long

mRow = 0: mCol = 0: flg = True
With wb.Worksheets(ShName)
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If DateValue(mDate) = .Cells(i, "A").Value Then
mRow = i
Exit For
End If
Next
If mRow = 0 Then
MsgBox "該当日が見つかりません。", vbCritical
flg = False
End If
Set FRange = .Range(.Cells(1, "B"), .Cells(1, "AZ")).Find(mItemStr, LookIn:=xlValues)
If Not FRange Is Nothing Then
mCol = FRange.Column
Else
MsgBox "該当項目が見つかりません。", vbCritical
flg = False
End If
If flg = True Then
.Cells(mRow, mCol).Value = mDATA
End If
End With
End Function

お礼

kkkkkm様、ありがとうございます。
おかげさまで希望が叶いました。
しかもわかりやすいコードで今後もアレンジしていけそうです。
この度はありがとうございました。

回答No.6

kkkkkm

No5で見つからなかった時のメッセージにシート名を入れないとどのシートかわからないので以下のように訂正してください。

MsgBox ShName & "： 該当日が見つかりません。", vbCritical

MsgBox ShName & "： 該当項目が見つかりません。", vbCritical

回答No.4

kkkkkm

No2の一部訂正です。

For i = 1 To LastRow
If DateValue(mDate) = .Cells(i, "A").Value Then
mRow = i
End If
Next

のところで Exit For が抜けてました。一致するデータがあればループを抜ける。

For i = 1 To LastRow
If DateValue(mDate) = .Cells(i, "A").Value Then
mRow = i
Exit For
End If
Next

お礼

ありがとうございます。
うまく転記できました。

ちなみにこちらを応用して転記する項目を増やそうとしたのですがうまくできませんでした。
日付と項目は同じで、転記するのがC2はBook2.xlsxのSheet3、D2はBook2.xlsxのSheet4、
E2はBook2.xlsxのSheet5としたい場合はどのようにしたらいいのでしょうか？

With wb.Worksheets("Sheet2")
から
End With

までをコピーして貼り付けてみましたができませんでした。

回答No.3

kon555

複数ブックにまたがる操作の場合は、どのブックに対する操作か、というのを明示してかけばいいです。
　具体的なやり方は以下参照。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_070_11.html
http://officetanaka.net/excel/vba/file/file05.htm
　これさえ押さえておけば、特に難しくないと思います。

　Book2.xlsxのSheet2の「B1～AZ1に項目が入っています」という、この項目の並び等が不変なら、直接指定してやればいいでしょう。項目が変化するなら、ForなりFindなりで項目一致を判定します。
　個人的には、Book1のA2とBook2のA列をForで一致検索、Book1の各項目名とBook2のB1～AZ1をForで一致検索、これで行列が定まるので数値入力にしますね。

お礼

kon555様、ありがとうございます。
アドバイスいただいたお話は理解できました。
ところがそれを書き出すとなると難しくて・・・。
教えていただいたURLも何度か拝見いたしました。
直接関係ないところも読み進めてみます。

回答No.2

kkkkkm

転記するタイミングで以下のコードを実行してください。Book2は裏で開くので表には見えません。Book2が開いているとエラーになります。
Sub Test()
Dim mDate As Date, mItemStr As String
Dim LastRow As Long, mRow As Long, mCol As Long
Dim ex As New Excel.Application
Dim mPath As String
Dim wb As Workbook
Dim FRange As Range, flg As Boolean
Dim i As Long

mDate = Sheets("Sheet1").Range("A2").Value
mItemStr = Sheets("Sheet1").Range("B1").Value
mRow = 0: mCol = 0: flg = True
mPath = "C:\ok\Book2.xlsx"
Set wb = ex.Workbooks.Open(Filename:=mPath)
With wb.Worksheets("Sheet2")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If DateValue(mDate) = .Cells(i, "A").Value Then
mRow = i
End If
Next
If mRow = 0 Then
MsgBox "該当日が見つかりません。", vbCritical
flg = False
End If
Set FRange = .Range(.Cells(1, "B"), .Cells(1, "AZ")).Find(mItemStr, LookIn:=xlValues)
If Not FRange Is Nothing Then
mCol = FRange.Column
Else
MsgBox "該当項目が見つかりません。", vbCritical
flg = False
End If
If flg = True Then
.Cells(mRow, mCol).Value = Sheets("Sheet1").Range("B2").Value
End If
End With
Call wb.Save
Call wb.Close
Call ex.Application.Quit
End Sub

回答No.1

imogasi

私見ですので、また直接の回答ではないので、読み飛ばしてください。
独学のＶＢＡの勉強の方向がよくないと思います。
良き指導者が周りにおれば別ですが。良き指導者を見つけるべきです。
前質問と本質問とも、コントロールに関する質問ですが、初心者がこういうユーザーインターフェースに、初めから首を突っ込むのは適当でないと思います。
よく自分も初心者なのに、他の初心者（職場の人など）に使ってもらう（スモール？にしろ）システムを考えている場合があるようだが、考慮すべきことや注意が必要。エラー対策やチェック，セキュリイェィなど、むしろベテランの域の技量が要求されることが多い。
ーー
小生の考える勉強の順序は
（０）エクセルの機能
　　　エクセルでどういうことが、操作ではできるか？
（１）VBAの文法、ＶＢＥ周りのこと
（２）シートに関すること（最大のテーマ）
（３）ブックに関すること
（４）ウインドウに関すること
（５）Ｖbscript,Fsoに関すること
（６）イベントやコントロールに関すること
　　　ユーザーフォームやコンボボックスなど。
（７）データベース、ＳＱＬに関すること
何よりも、上記とは別に、処理ロジック・処理方法・筋道などについて、本やＷＥＢで勉強して修行することです。
（１）－（７）はその中の手段を提供するものです。
ーー
質問者は、コントロールの本を１冊でも読みましたか？
中途半端な段階で質問すると、高等な方法での回答が出たりして、本当に他に手段がないか、など判断できず、混乱すると思う。
ーー
また我流の、関心による、また状況設定での質問であるため、回答が複雑になって、本筋がわかりにくくなります。前の質問やこの質問、がそうです。
もっとスモールな要素に分解して質問できるようになりましょう。

・

お礼

imogasi様、ありがとうございます。
急に仕事でやらなくてはならなくなり、焦って進めてしまいました。

自分がやりたいことをネットで調べながら似たようなものを探しては取り入れ、
を繰り返してなんとか形にしようと思っています。
基本的な知識がゼロから始めてしまったので、
マクロの記録や他のQ&Aのコードを見ながら、
その意味を調べて理解するように努めております（全ては理解できておりませんが）。

基本も勉強しながら進めていきたいと思います。