質問: 閲覧ありがとうございます。 エクセルの作業ファイルにてVBAのコードを作成しているのですが、中々思う通りに実行できないので、ご教授願います。 実行したい内容については以下の通りです。 ボタン1を押すと(添付画像上段のブック)、マイドキュメント内にある「データ転送ソフト2」という名前のブックを開き、そのブックのシート「A」内(添付画像下段)の、ボタン1を押したシートのF1セル(添付画像上段のブック)と同じ文字(日付)の列と"う"と入力された行の交差したセルの数値(添付画像下段の紫色のセル)をコピーして、ボタン1を押したシートのT4のセル(転送値1:の右隣にある薄緑のセル)に貼り付ける作業が行えるコードをご教授願いたいです。 要約しますと、作業しているシートのボタン1を押すと、別の場所にあるブックを開き、そのシート内の条件に沿った数値をコピーして、作業しているシートの指定されたセルに貼り付ける作業が行いたいです。 とても分かりにくい文章で申し訳ございませんが、お願いします。 可能ならば、コードの解説もつけてくださると嬉しいです。
回答: 質問内容を実現するコードを書いてみました。 検索する場所や値の設定方法を工夫すれば色々改良できるようにしたつもりです。 ボタンに回答のマクロを登録してください。 >可能ならば、コードの解説もつけてくださると嬉しいです。 コードにコメントを付けたのでわかると思いますが。。。 添付図のボタンを見ると、「フォームコントロールのボタン」のように見えます、「フォームコントロール」も場合によっては便利ですが、今は、「ActiveXコントロール」が一般的で、使いやすいと思います。参考までに。当方win10、Excel2010です。 Sub データ転送() Dim wb As Workbook '// マクロを動かしているブック Set wb = ActiveWorkbook '// 探す日付(列)と探す文字(行) Dim schDate As Date '// 探す日付(列) Dim schString As String '// 探す文字(行) schDate = Range("F1") '// 値をセット schString = "う" '// 値をセット Application.ScreenUpdating = False '// 画面更新をストップ '// データ転送ソフト2を開く Dim BookPath As String '// データ転送ソフト2.xlsxのパス Dim BookName As String '// Book名 BookPath = "C:\Users\nishi6\Documents" '// **** ご自分のパスをセット **** BookName = "データ転送ソフト2.xlsx" '// **** 実情に合うように変更 **** Workbooks.Open BookPath & "\" & BookName '// ブックのフルパス Dim wbDT As Workbook '// データ転送ソフト2.xlsx Set wbDT = ActiveWorkbook '// データ転送ソフト2を調べる Dim r As Long '// 行カウンタ Dim c As Long '// 列カウンタ Dim findRow As Long '// 見つけた値(行) Dim findCol As Long '// 見つけた値(列) Dim findVal As Variant '// 見つけた値(列) r = 1: c = 1 '// 行カウンタ、列カウンタの初期化 Worksheets("A").Activate '// データ転送ソフト2.xlsxにフォーカス With Range("B4") '// B4セルを起点にOffsetで調べる '// B列を調べる '// データがあって、見つからない場合、調べ続ける While .Offset(r, 0) <> "" And findRow = 0 If .Offset(r, 0) = schString Then findRow = r End If r = r + 1 '// 次の行を調べる Wend '// 4行目を調べる '// データがあって、見つからない場合、調べ続ける While .Offset(0, c) <> "" And findCol = 0 If .Offset(0, c) = schDate Then findCol = c End If c = c + 1 '// 次の列を調べる Wend '// 探した値を取り込む If findRow <> 0 And findCol <> 0 Then '// 見つかった場合 findVal = .Offset(findRow, findCol) Else '// 見つからなかった場合は何もしない End If End With '// 結果を返す wb.Activate If findRow <> 0 And findCol <> 0 Then Range("T4") = findVal Else MsgBox "指定された日付:" & Format(schDate, "yyyy/m/d") & _ " は見つかりませんでした。" End If '// データ転送ソフト2.xlsxブックを閉じる Application.DisplayAlerts = False wbDT.Close Application.DisplayAlerts = True Application.ScreenUpdating = True '// 画面更新を再開 End Sub