VBA 別シート、別ブックへ条件一致で転記

質問

先日もアンケートの結果入力について質問させて頂いたのですが、
アンケートの仕様が変わってしまい、自分で直そうとしたのですがうまくできず、すみませんがまた教えてください。。。

アンケートの結果を集計するため、入力用シートにデータを入力しています。
入力用シートの構造は、上部のヘッダ部分に、担当者、社名、発売日、商品名の4つの情報があり
その下に設問が18問あり、設問の右のセルにチェックボックスがあって、
チェックあり、なしを入力していくようになっています。
チェックボックスの値は非表示のセルにリンクするようにしています。

となりのデータベースシートにその結果を転記していきたいのですが、
データベースシートにはあらかじめ多数の担当者、社名、発売日、商品名の情報が入っていて、
入力シートのヘッダ部分の4項目全てと一致する行に、アンケートの入力結果を転記したいです。

入力シート
担当者名 鈴木
会社名 A株式会社
発売日 11/21
商品名 りんご

設問1 チェックあり
設問2 チェックなし
設問3 チェックあり
…
設問18 チェックあり

データベースシート
担当者名 会社名 発売日 商品名 設問1 設問2 … 設問18
鈴木 B株式会社 10/30 なし
佐藤 C株式会社 12/5 ぶどう
高橋 A株式会社 11/1 いちご
鈴木 A株式会社 11/21 りんご
・・・・・・

上記例ではデータベースシートの上から4行目のところに、設問1～18の結果を横に並べて転記したいです。

また、それとは別に、データベースシートと同じ構造の別ブックに同様にデータを転記していくマクロも知りたいです。(実行時にファイルを開いて、同じように4条件全部一致した行にデータを転記したい)

説明が下手で申し訳ないですが何卒お助け下さい。。
よろしくお願いいたします<(_ _)>

回答No.1

keithin

えっと。回答を貰っても，何が気にくわなかったのかプイッと閉じ逃げで去ってしまわれたご相談の，続きのご相談ですね。

それと前回も「具体的なマクロが教わりたいときは，なんて名前のシートのドコ番地のセルに何を記入してる」のか手抜きせず判るように情報提供して下さいってお話ししておきましたが，そういう所もスルーのままですね。これで２回お話ししましたから，次の３回目はもう大丈夫ですね？

さて。
「具体的な」説明の書き方の例：
シート名Sheet1のＢ１からＢ４セルに担当者名から商品名までを記載している
設問１、２，３…１８のチェックボックスをそれぞれＡ１１からＡ２８セルにリンクしている
フォームコントロールのコマンドボタンをシートに配置している
（アクティブＸコントロールのコマンドボタンではないので間違えない事）

各情報を、シート名Sheet2のＡ，Ｂ，Ｃ，Ｄ列を探してＥ列以右に順番に転記していく
Sheet2は１行目をタイトル行として記入済みで、２行目から記入していく

手順：
ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro2()
　dim r as long
　dim LastRow as long
　lastrow = worksheets("Sheet2").range("A65536").end(xlup).row

　for r = 1 to lastrow
　　if worksheets("Sheet1").range("B1") = worksheets("Sheet2").cells(r, "A") _
　　and worksheets("Sheet1").range("B2") = worksheets("Sheet2").cells(r, "B") _
　　and worksheets("Sheet1").range("B3") = worksheets("Sheet2").cells(r, "C") _
　　and worksheets("Sheet1").range("B4") = worksheets("Sheet2").cells(r, "D") then
　　　exit for
　　end if
　next r

　if r > lastrow then
’リストに該当が無かった場合
　worksheets("Sheet2").cells(r, "A") = worksheets("Sheet1").range("B1")
　worksheets("Sheet2").cells(r, "B") = worksheets("Sheet1").range("B2")
　worksheets("Sheet2").cells(r, "C") = worksheets("Sheet1").range("B3")
　worksheets("Sheet2").cells(r, "D") = worksheets("Sheet1").range("B4")
　end if

’転記
　worksheets("Sheet2").cells(r, "E") = worksheets("Sheet1").range("A11").value
　worksheets("Sheet2").cells(r, "F") = worksheets("Sheet1").range("A12").value
　worksheets("Sheet2").cells(r, "G") = worksheets("Sheet1").range("A13").value
　worksheets("Sheet2").cells(r, "H") = worksheets("Sheet1").range("A14").value
　worksheets("Sheet2").cells(r, "I") = worksheets("Sheet1").range("A15").value
　worksheets("Sheet2").cells(r, "J") = worksheets("Sheet1").range("A16").value
　worksheets("Sheet2").cells(r, "K") = worksheets("Sheet1").range("A17").value
　worksheets("Sheet2").cells(r, "L") = worksheets("Sheet1").range("A18").value
　worksheets("Sheet2").cells(r, "M") = worksheets("Sheet1").range("A19").value
　worksheets("Sheet2").cells(r, "N") = worksheets("Sheet1").range("A20").value
　worksheets("Sheet2").cells(r, "O") = worksheets("Sheet1").range("A21").value
　worksheets("Sheet2").cells(r, "P") = worksheets("Sheet1").range("A22").value
　worksheets("Sheet2").cells(r, "Q") = worksheets("Sheet1").range("A23").value
　worksheets("Sheet2").cells(r, "R") = worksheets("Sheet1").range("A24").value
　worksheets("Sheet2").cells(r, "S") = worksheets("Sheet1").range("A25").value
　worksheets("Sheet2").cells(r, "T") = worksheets("Sheet1").range("A26").value
　worksheets("Sheet2").cells(r, "U") = worksheets("Sheet1").range("A27").value
　worksheets("Sheet2").cells(r, "V") = worksheets("Sheet1").range("A28").value
end sub

それと？
＞それとは別に、データベースシートと同じ構造の別ブックに同様にデータを転記していくマクロも知りたいです。

それは，単に転記先が違うだけで仕事は（＝マクロは）一緒という事で良いんですね。
基本は「workbook("ブック名.拡張子").worksheets("シート名").…」のように，具体的にどのブックの具体的にどのシートの具体的にドコのセル番地と指定するだけです。

お礼

ありがとうございます!!!
思った通りにシート転記できました!!!

また先の質問には回答者の皆様にお礼のコメントを入れたつもりだったのですが、うまく反映されていなかったのか、不愉快な思いをさせてしまったようで申し訳ございません。

あの後色々やってみたのですがうまくいかず、仕様も変わってしまったため再質問させて頂いた次第です。

すみませんがもう一つ教えて頂きたいのですが、別ブックに転記する際、そのファイルは作業のつど変わる可能性があり(中身の構造は同じです)、別の転記ボタンを作ってクリックするときに選択する方式にしようと思っています。
いま頂いたコードで書き換えて作ってみたのですがエラーになってしまい。。。
どうしたらよいでしょうか。ご教授いただけないでしょうか。

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