• ベストアンサー
  • すぐに回答を!

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

  • 質問No.9661050
  • 閲覧数161
  • ありがとう数3
  • 気になる数0
  • 回答数3
  • コメント数0

お礼率 100% (3/3)

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

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

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

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

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

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

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

質問者が選んだベストアンサー

  • 回答No.3
  • ベストアンサー

ベストアンサー率 61% (246/403)

[技術者向] コンピューター カテゴリマスター
提示された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 [A$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
お礼コメント
nyaaaaaaaao

お礼率 100% (3/3)

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

ご回答ありがとうございます。
投稿日時:2019/10/02 15:41

その他の回答 (全2件)

  • 回答No.2

ベストアンサー率 27% (4510/16108)

質問者の記述振りを見ていると、こういうイベントを使う課題や、ブックを別にして処理する方法をとるのは、まだ早すぎると思う。
まして質問者以外のものに、使わせようとするなら、もっと経験を積む必要があるだろう。
小生は、小手先調べでやってみたが、うまく伝わるか心配。
うまく行かない時は、この回答は無視してください。
(1)ブックは2つ作る
  A.検索のためのボタンのあるブック。シートはSheet1とする。
   "C:\Users\XXX\Documents\日付で検索.xlsm" XXXXはユーザー名。
  B。検索されるデータがあるブック。シートはSheet1とする。
   "C:\Users\XXX\Documents\データ例0927.xlsx"
(2)AのSheet1に、検索の引き金を引く、ボタン的なものを作る。
   下記のように、色々考えられる。
   a.図形(四角形)でマクロを登録
   開発ー挿入で作るところの
   b.コントトールのボタンなど
 c.ActiveXコントロールのボタンなど
   ユーザー・フォームを設けてやる
   d.ユーザーフォームを設けて、その上にボタンを作る
  本回答では、aを使った。
  この図形をクリックした、クリックイベントで検索を実行する。
  登録するマクロ(処理内容)は、標準モジュールのTest02の名のもとに記述。
(3)Aブックを開くと、最初にAutoOpenでBブックを開く。
   Aブックを閉じると、Bブックも閉じて終わる。
====
データ例
AブックのSheet1
  F1とF2セルに 日付と区分(小生が命名しただけ)を入力しておく
2019/1/11

これは検索する直前までに入力しておく。
この範囲チェックは省略している。
上述の、クリックする図形(四角形)を1つ、Sheet1に張り付けておく。
====
検索されるデータの例(小生が一部勝手に作成したもの)
BブックのSheet1 B4:I9
日付/区分2019/1/92019/2/132019/1/112019/1/122019/1/132019/1/142019/1/15
あ11213141516171
い12223242526272
う13233343536373
え14243444546474
お15253545556575
=======
以下は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\データ例0927.xlsx")
Set ws = wb.Worksheets("Sheet1")
'Set wb = Workbooks("C:\Users\惇\Documents\データ例0927.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\データ例0927.xlsx"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Workbooks("データ例0927.xlsx").Close Savechanges:=True
End Sub
====
BブックにはVBAコード無し。
====
利用
AブックのSheet1の
F1に検索する日付
F2に検索する区分
を入力しておく

AブックのSheet1の四角形をクリック
ーー
結果
この回答では、とりあえず、画面表示のみ。
MsgBox "結果 " & ws.Cells(x, y)の箇所。
実際はこの値が後処理で、何かに使われるのだろう。質問には記述無し?
お礼コメント
nyaaaaaaaao

お礼率 100% (3/3)

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

仰るとおり経験不足なので、基礎から学ぼうと思います。
投稿日時:2019/10/02 15:43
  • 回答No.1

ベストアンサー率 68% (867/1275)

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

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

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

お礼率 100% (3/3)

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

上記コードで動作確認できました。
投稿日時:2019/10/02 15:29
結果を報告する
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。
関連するQ&A

その他の関連するQ&Aをキーワードで探す

ピックアップ

ページ先頭へ