2つの条件に合致したセルに転記したい

Question

転記元のA24に年月、B22にキーワード、B24に数値が入っています。

転記先の行番号1の中から転記元B22と合致する行を探し出し、
転記先A列と転記元A24が合致するセルに転記元B24を転記したいです。

２つの条件に合致したセルに転記したい場合は、
VBAだとどのように記述したら良いのでしょうか？

Comments

[meg_]

・「転記先の行番号1の中から転記元B22と合致する行を探し出し」とはどういう意味ですか？
・転記元と転記先は同じブックですか？違うブックですか？
・出来たところまでのコードを追記してください。（ブック開くところとか）

[mi_ku]

・転記先の各列1行目にそれぞれキーワードが記載されておりますので、その中からB22と同じキーワードを探したいと思いました。
・転記元と転記先は別のブックです。
・以下のようなコードでEnd Subの前にコードを入れるつもりでした。

Sub tenki()

Dim wb As Workbook
Workbooks.Open Filename:= _
"C:\Users\ファイル名.xlsm"
Set wb = ActiveWorkbook

End Sub

よろしくお願いいたします。

Answer 1

Sub test()
    Dim rngTopItem As Range
    Dim rngSideItem As Range
    Dim rngNumValue As Range
    Dim rngDataBody As Range
    Dim ixRow As Long
    Dim ixCol As Long
    
    With Worksheets(1)
        '転記元のA24
        Set rngSideItem = .Range("A24")
        '転記元のB22
        Set rngTopItem = .Range("B22")
        '転記元のB24
        Set rngNumValue = .Range("B24")
    End With
    '転記先
    With Worksheets(2).Range("A1").CurrentRegion
        Set rngDataBody = Intersect(.Cells, .Offset(1, 1))
    End With
    
    With WorksheetFunction
        '書き込み先行番号の検索
        ixRow = .Match(rngSideItem.Value2, rngDataBody.Columns(1), 0)
        '書き込み先列番号の検索
        ixCol = .Match(rngTopItem.Value, rngDataBody.Rows(0), 0)
    End With
    
    '値の転記
    rngDataBody(ixRow, ixCol).Value = rngNumValue.Value
End Sub

僕が書くとこんな感じとか。
セル範囲を先に決めちゃって、
それに対してなにかする感じ＾＾；

ワークシート上で使うMatch関数を使ってます。
検索で見つからなかったらエラーになりますので、
エラー回避処理を入れないとだめかなぁ。。。。

あと、気になった点。
＞転記元のA24に年月

単に年月と書かれてますが、
例えばセルに何も考えずに、
2020/4
と入れたら、2020/4/1を示す「数値」がセルの値に保存されます。
（43922というシリアル値）
で、勝手にエクセル君がセルの書式設定をYYYY/Mとかに変えてます。
そうでないなら、単にセルの書式設定を文字列にしてるとか。
とにかく、勝手にこちらが日付って思っていても、
中身が違ったり、エクセル君が日付と読んでくれない
可能性がエクセルには多々あります。
特にFindメソッドを使った検索では、
「値」としても、表示されている文字列を検索するため、
値が同じでも、セルの表示形式の違いでヒットしない場合がるので、
Findメソッドの日付の検索はトラブルが多いです。
（細心の注意を払えば大丈夫ですが。）
Match関数の方は「セルの値」で検索しますので、トラブルが少ないですが、
そもそもの「セルの値」＝「セルに表示されている文字列」とは、
エクセルでは担保されないので注意が必要です。

Comments

[mi_ku]

mattuwanさんありがとうございます。

転記元のA24ですが、表記は年月ですが中身は=A22&"年"&A23&"月"となっています。
転記先は年/月/日になっています。
ご指摘いただいた内容ですと、ここは同じものとしてみてもらえていないということでしょうか？

[mi_ku]

先日はアドバイスありがとうございました。
せっかく教えていただいたので、こちらも実現できないかと思い、チャレンジしてみました。
ところが「実行時エラー1004　WorksheetFunctionクラスのMatchプロパティを取得できません」と出てしまいます。
以下のようにしてみたのですが、どこがおかしいか教えていただけませんでしょうか？
なお転記元のA24は計算式ではなく日付にして転記先と同じにしてあります。

Sub test()
Dim rngTopItem As Range
Dim rngSideItem As Range
Dim rngNumValue As Range
Dim rngDataBody As Range
Dim ixRow As Long
Dim ixCol As Long

Set Wb = Workbooks.Open(Filename:="C:\Users\ファイル名.xlsm")
Set Sh = Wb.Sheets("価格")

With Worksheets("Sheet1")
'転記元のA24
Set rngSideItem = .Range("A24")
'転記元のB22
Set rngTopItem = .Range("B22")
'転記元のB24
Set rngNumValue = .Range("B24")
End With
'転記先
With Sh.Range("A1").CurrentRegion
Set rngDataBody = Intersect(.Cells, .Offset(1, 1))
End With

With WorksheetFunction
'書き込み先行番号の検索
ixRow = .Match(rngSideItem.Value2, rngDataBody.Columns(1), 0)
'書き込み先列番号の検索
ixCol = .Match(rngTopItem.Value, rngDataBody.Rows(0), 0)
End With

'値の転記
rngDataBody(ixRow, ixCol).Value = rngNumValue.Value
End Sub

Answer 2

test1.xlsmとtest2.xlsxをDドライブのカレントでテストしました。

Sub tes()

Dim Wb As Workbook
Dim Sh As Worksheet
Dim ThisSh As Worksheet
Dim Clo As Long
Dim Rws As Long

Set Wb = Workbooks.Open(Filename:="d:\test2.xlsx")
Set Sh = Wb.Sheets("Sheet1")

Set ThisSh = ThisWorkbook.Sheets("Sheet1")

col = ThisSh.Range("1:1").Find(What:=Sh.Range("B22")).Column
Rws = ThisSh.Range("A:A").Find(What:=Sh.Range("A24")).Row
ThisSh.Cells(Rws, col).Value = Sh.Range("B24")

Set ThisSh = Nothing
Set Sh = Nothing
Set Wb = Nothing

End Sub

実行後

追記
test1.xlsxとtest2.xlsmとする場合
開くファイルがtest1.xlsxになり、ShとThisShを入れ替えることになります。

Sub tes2()

Dim Wb As Workbook
Dim Sh As Worksheet
Dim ThisSh As Worksheet
Dim Clo As Long
Dim Rws As Long

Set Wb = Workbooks.Open(Filename:="d:\test1.xlsx")
Set Sh = Wb.Sheets("Sheet1")

Set ThisSh = ThisWorkbook.Sheets("Sheet1")

col = Sh.Range("1:1").Find(What:=ThisSh.Range("B22")).Column
Rws = Sh.Range("A:A").Find(What:=ThisSh.Range("A24")).Row
Sh.Cells(Rws, col).Value = ThisSh.Range("B24")

Set ThisSh = Nothing
Set Sh = Nothing
Set Wb = Nothing

End Sub

追記２
実行している.xlsmファイルのある場所（フルパス）は

Path =ThisWorkbook.Path

で取得できます。
またデスクトップへのフルパスは

Dim Path As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    Path = WSH.SpecialFolders("Desktop") 

Comments

[mi_ku]

sinzouさん、ありがとうございます。
お返事が遅くなり、すみません。

表を作って検証までしていただいて恐縮です。
私がやりたかったのは、まさにこのことです。

最後にもう一つ教えてください。
教えていただいたコードですと、test1.xlsmに記述をすると思うのですが、
test2のほうに記述をしたいと思います。
転記元にボタンを作ってそれをクリックしたら転記先に転記されるようにしたいと思っております。

test2.xlsxが転記元のマクロを記述するファイルで、
test1.xslmが転記先のファイルの場合はどのように記述したらよいのでしょうか？

[tatsu99]

横からお邪魔します。
>test2.xlsxが転記元のマクロを記述するファイルで、
>test1.xslmが転記先のファイルの場合はどのように記述したらよいのでしょうか？
ということですが、test2.xlsxにマクロを記述することはできません。
マクロを記述する場合は、拡張子をxlsmにする必要があります。
つまり、test2.xlsmになら記述可能です。

[sinzou]

追記しました。

[mi_ku]

tatsu99さん、ありがとうございます。
質問の仕方が悪く、すみません。
次回から拡張子についてもちゃんと記載するようにいたします。

[mi_ku]

sinzouさん、ありがとうございます。
早速試してみたのですが、

オブジェクト変数またはWithブロック変数が設定されていません。

と表示されてしまいます。

これは何がいけないのでしょうか？

[sinzou]

１．エラーで停止したとき、どの行が黄色で示されるのでしょうか
２．サンプルをコピペで入力していただいてますでしょうか。

[mi_ku]

エラーが出てもどの行も黄色くはなりませんでした。
コードは以下のようにしております。
コピペしたつもりでしたが、どこかおかしいでしょうか？

Sub 登録()

Dim Wb As Workbook
Dim Sh As Worksheet
Dim ThisSh As Worksheet
Dim Clo As Long
Dim Rws As Long

Set Wb = Workbooks.Open(Filename:="C:\Users\ファイル名.xlsm")
Set Sh = Wb.Sheets("価格")

Set ThisSh = ThisWorkbook.Sheets("Sheet1")

col = Sh.Range("1:1").Find(What:=ThisSh.Range("B22")).Column
Rws = Sh.Range("A:A").Find(What:=ThisSh.Range("A24")).Row
Sh.Cells(Rws, col).Value = ThisSh.Range("B24")

Set ThisSh = Nothing
Set Sh = Nothing
Set Wb = Nothing

End Sub

[sinzou]

C:\Users\　フォルダーはアクセス権とうあるのでやめたほうが良いです。

D:\　のフォルダーに、ファイル名.xlsm　が有るとして

コマンドボタンで呼び出しても動くのですが
コマンドボタンでほかの処理書いていますか？

Private Sub CommandButton1_Click()
Call 登録
End Sub

[mi_ku]

コードはとりあえずそのまま実行していました。
コマンドボタンは使用しておりますが、名前を変更していますのでCommandButton1というのはありませんでした。

[mi_ku]

フォルダの場所を変えたほうよいということでしょうか？？？

[sinzou]

単体で動くか確認お願いします。
Sub 　登録（）　内にカーソルを置いて、F5等で直接、単独実行できますでしょうか？

[sinzou]

C:\UsersはWindowsのシステムが、ログインユーザーのフォルダーが作成される場所なので、、

[mi_ku]

F5を押すと実行時エラー91と出ます。

[sinzou]

ふむ～　どこがひっかかっているのか、、、
１．”価格”シートのあるファイル名.Xlsmファイルがある。
２．Sub 登録のある別の.xlsmファイルがある。
３．Sub 登録を単独実行しても　エラー91がでる。

[mi_ku]

1.ファイル名もシート名も、同じものはありませんでした。
2.Sub　登録は一つしかありませんでした。

F8を押していくと
col = Sh.Range("1:1").Find(What:=ThisSh.Range("B22")).Column
で止まりました。

[sinzou]

すみません、仕様を確認したいです。
１．書き込むデータを持ったファイルのファイル名（Sub 登録がある）とデーターのあるシート名
２．書き込まれるファイルのファイル名と保存してある場所、とファイルにシート（”価格”）がある。
二つのファイルの保存場所、ファイル名と各シート名を明確にしたいです。

https://teratail.com/questions/258596でもC:\Users\話題になってたようですが、変える考えはないのでしょうか。

[mi_ku]

お返事が遅くなってすみません。

1.書き込む方のファイル名は（test11.xlsm）で、シート名は（Sheet1）です
2.書き込まれる方のファイル名は（testf.xlsm）で、保存してある場所はデスクトップの（TAST中）というフォルダで、そこに（価格）という名前のシートがあります

二つとも同じ（TEST中）フォルダに入っています。

フォルダをデスクトップではなく別な場所に移動すればよいのでしょうか？

[sinzou]

同じフォルダーにあるのでしたら、ThisWorkbook.Pathを使って

Set Wb = Workbooks.Open(Filename:=ThisWorkbook.Path＆"\testf.xlsm")

[mi_ku]

何度もお手数をお掛けしてすみません。

原因がわかりました。
コピー先の1行目が文字列ではなく計算式になっていることと、
A24が計算式になっていることかと思います。
試しに1行目を文字列にして、A24を数字で日付を入れてやってみたらうまくいきました。
しかし数値は反映されますが途中で止まってしまい、□（停止）ボタンを押さなければならないようです。

転記先の1行目や転記元のA24が計算式の場合は転記することはできないのでしょうか？

[sinzou]

A24セルに計算式で日付けを文字列として作成されているのでしたら
１．価格シートの日付けを文字列にする
２．価格シートの日付けはシリアル値のままでA24セルの値をシリアル値に変換する
文字列の火付けをシリアル値に変換する　DateValue　使用する。
Rws = Sh.Range("A:A").Find(What:=DateValue(ThisSh.Range("A24"))).Row

[mi_ku]

ありがとうございます。
計算式のところを直したら思い通りに動きました！
何度も教えていただきまして、ありがとうございました。

[mi_ku]

終わった後ですみません。
全て希望通りに動作するようになったのですが、最後にリセットボタン（停止ボタン）を押さないと終了しないのですが、これはどうしたらいいのでしょうか？

[sinzou]

１．開いたtestf.xlsmを閉じる場合
Wb.Save '上書き保存
Wb.Close 'ブック（testf.xlsm）を閉じる。
になります。
２．’停止ボタンを押さないと終了しない’　は
Sub 登録を呼び出している所の次の行以降にブレークポイントを置いてステップ実行でどのような動きしているか確認願います。

[mi_ku]

再度のアドバイスありがとうございます。
Wb.Save
Wb.Close
を追加して実行してみましたが、実行時エラー91、
オブジェクト変数またはWithブロック変数が設定されていません。
と出てしまいます。

[sinzou]

Set Wb = Workbooks.Open(Filename:="d:\test1.xlsx")
でオブジェクトをWbに収めて
Set Wb = Nothing
で開放しています。

.Save、.Closeは、開放する前に入れてください。