エクセル内でのVBAの質問です。

質問

閲覧ありがとうございます。

エクセルの作業ファイルにてVBAのコードを作成しているのですが、中々思う通りに実行できないので、ご教授願います。

実行したい内容については以下の通りです。

ボタン1を押すと(添付画像上段のブック)、マイドキュメント内にある「データ転送ソフト2」という名前のブックを開き、そのブックのシート「A」内(添付画像下段)の、ボタン1を押したシートのF1セル(添付画像上段のブック)と同じ文字(日付)の列と"う"と入力された行の交差したセルの数値(添付画像下段の紫色のセル)をコピーして、ボタン1を押したシートのT4のセル(転送値1:の右隣にある薄緑のセル)に貼り付ける作業が行えるコードをご教授願いたいです。

要約しますと、作業しているシートのボタン1を押すと、別の場所にあるブックを開き、そのシート内の条件に沿った数値をコピーして、作業しているシートの指定されたセルに貼り付ける作業が行いたいです。

とても分かりにくい文章で申し訳ございませんが、お願いします。

可能ならば、コードの解説もつけてくださると嬉しいです。

回答No.3

HohoPapa · ベストアンサー

提示された2つ目の画像のB4セルに
例えば"項目"という文字列を埋めてもらえるのであれば
下記のコードで期待の動作になるハズです。

Sub Sample()

　Dim cn As Object
　Dim rs As Object
　Dim SQL As String
　Dim shF As String
　Const TgBook = "C:\Users\papa\Documents\データ転送ソフト2.xlsx"
　'↑：検索対象ブックのフルパス
　Const TgName = "う"　'検索する項目列の文字列

　'シートを定義
　shF = "FROM [Ａ$B4:Z64000]"　'検索対象シート名と範囲
　'↑B4を起点に広めな範囲を指定できます

　'DBを定義、設定
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open TgBook

　'SQL文を組立、実行
　SQL = "select [" & Range("F1").Value & "] as HitCnt" & vbCrLf
　SQL = SQL & shF & vbCrLf
　SQL = SQL & "WHERE (" & vbCrLf
　SQL = SQL & "[項目] = '" & TgName & "'" & vbCrLf
　SQL = SQL & ")" & vbCrLf
　On Error GoTo MyError
　rs.Open SQL, cn

　'検索結果を指定セルに格納
　Range("T4").Value = rs("HitCnt")
　'MsgBox (rs("HitCnt"))

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing
　Exit Sub

MyError:
　Select Case Err.Number
　　Case -2147217904　　 'SQL文でエラーの時
　　　 MsgBox "指定の日が見つかりません"
　　Case Else
　　　 MsgBox "予期せぬエラーが発生しました" & vbCrLf & Err.Number & ":" & Err.Description
　　End Select

End Sub

お礼

今現在、私が行おうと思っている作業に一番近い動作だと思います。

ご回答ありがとうございます。

回答No.2

imogasi

質問者の記述振りを見ていると、こういうイベントを使う課題や、ブックを別にして処理する方法をとるのは、まだ早すぎると思う。
まして質問者以外のものに、使わせようとするなら、もっと経験を積む必要があるだろう。
小生は、小手先調べでやってみたが、うまく伝わるか心配。
うまく行かない時は、この回答は無視してください。
（１）ブックは２つ作る
　　A.検索のためのボタンのあるブック。シートはSheet1とする。
　　　"C:\Users\XXX\Documents\日付で検索.xlsm"　XXXXはユーザー名。
　　B。検索されるデータがあるブック。シートはSheet1とする。
　　　"C:\Users\XXX\Documents\データ例０９２７.xlsx"
（２）AのSheet1に、検索の引き金を引く、ボタン的なものを作る。
　　　下記のように、色々考えられる。
　　　a.図形（四角形）でマクロを登録
　　　開発ー挿入で作るところの
　　　b.コントトールのボタンなど
　c.ActiveXコントロールのボタンなど
　　　ユーザー・フォームを設けてやる
　　　d.ユーザーフォームを設けて、その上にボタンを作る
　　本回答では、aを使った。
　　この図形をクリックした、クリックイベントで検索を実行する。
　　登録するマクロ（処理内容）は、標準モジュールのTest02の名のもとに記述。
（３）Aブックを開くと、最初にAutoOpenでBブックを開く。
　　　Aブックを閉じると、Bブックも閉じて終わる。
＝＝＝＝
データ例
AブックのSheet1
　　F1とF2セルに　日付と区分（小生が命名しただけ）を入力しておく
2019/1/11
い
これは検索する直前までに入力しておく。
この範囲チェックは省略している。
上述の、クリックする図形（四角形）を１つ、Sheet1に張り付けておく。
＝＝＝＝
検索されるデータの例（小生が一部勝手に作成したもの）
BブックのSheet1　B4:I9
日付／区分 2019/1/9 2019/2/13 2019/1/11 2019/1/12 2019/1/13 2019/1/14 2019/1/15
あ 11 21 31 41 51 61 71
い 12 22 32 42 52 62 72
う 13 23 33 43 53 63 73
え 14 24 34 44 54 64 74
お 15 25 35 45 55 65 75
＝＝＝＝＝＝＝
以下はVBAコード関連のこと。
＝＝＝＝
AブックのModule1　に
Sub test02()
MsgBox "検索します"
dt = ActiveWorkbook.Sheets("Sheet1").Range("F1")
MsgBox "日付 " & dt
kbn = ActiveWorkbook.Sheets("Sheet1").Range("F2")
MsgBox "区分　" & kbn
'---
Set wb = Workbooks.Open("C:\Users\惇\Documents\データ例０９２７.xlsx")
Set ws = wb.Worksheets("Sheet1")
'Set wb = Workbooks("C:\Users\惇\Documents\データ例０９２７.xlsx")
'y = Application.WorksheetFunction.Match(dt, ws.Range("C4:I4"), 0)
y = ws.Range("C14:I4").Find(dt).Column
'MsgBox y
x = ws.Range("B5:B9").Find(kbn).Row
'MsgBox x
MsgBox "結果 " & ws.Cells(x, y)
End Sub
＝＝＝＝
自動でデータのあるブックを開いたり、閉めたりするために、
AブックのThisworkbook　に
Private Sub Workbook_Open()
Workbooks.Open "C:\Users\惇\Documents\データ例０９２７.xlsx"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Workbooks("データ例０９２７.xlsx").Close Savechanges:=True
End Sub
＝＝＝＝
BブックにはVBAコード無し。
＝＝＝＝
利用
AブックのSheet1の
F1に検索する日付
F２に検索する区分
を入力しておく
ー
AブックのSheet1の四角形をクリック
ーー
結果
この回答では、とりあえず、画面表示のみ。
MsgBox "結果 " & ws.Cells(x, y)の箇所。
実際はこの値が後処理で、何かに使われるのだろう。質問には記述無し？

お礼

丁寧にご回答ありがとうございます。

仰るとおり経験不足なので、基礎から学ぼうと思います。

回答No.1

nishi6

質問内容を実現するコードを書いてみました。
検索する場所や値の設定方法を工夫すれば色々改良できるようにしたつもりです。
ボタンに回答のマクロを登録してください。

＞可能ならば、コードの解説もつけてくださると嬉しいです。
コードにコメントを付けたのでわかると思いますが。。。

添付図のボタンを見ると、「フォームコントロールのボタン」のように見えます、「フォームコントロール」も場合によっては便利ですが、今は、「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

お礼

ご回答ありがとうございます。

上記コードで動作確認できました。