エクセルVBAで別のシートの値をコピーして指定のセルに貼り付ける方法

質問

• エクセルVBAを使用して、別のシートの条件に沿った数値をコピーして指定のセルに貼り付ける方法について教えてください。
• 作業しているシートのボタンを押すと、別の場所にあるブックを開き、そのシート内の特定の条件に沿った数値をコピーして、作業しているシートの指定されたセルに貼り付けるコードについて教えてください。
• エクセルのVBAで、別のシートの特定の条件に沿った数値をコピーして、作業しているシートの指定されたセルに貼り付ける方法について教えてください。

回答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

お礼

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

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