お世話になります
現在ADOにてEXCEL側からAccessDBにアクセスし
値を取得しているのですが
現在下方向に貼り付けしているのですが
横方向に貼り付けさせる方法はありますか?
下記参考(現状VBAです)
現状:日付で絞込みをしています
日付け絞込みをしてヒットしたものに対して下方向に貼り付けています
それを横方向に貼り付けさせたいのです
Private Sub CommandButton1_Click()
Dim myConn As ADODB.Connection
Dim myRs As ADODB.Recordset
Dim mySQL As String
Dim myConstr As String
Dim myDBFName As String
Dim myPswd As String
Dim tableName As String
Dim orderDate As String
Dim shipDate As String
orderDate = Format(DateValue(DTPicker1.Value), "mm/dd/yyyy")
shipDate = Format(DateValue(DTPicker2.Value), "mm/dd/yyyy")
myDBFName = "Accessパス"
myPswd = ""
myConstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& myDBFName & ";Jet OLEDB:Database Password=" & myPswd & ";"
mySQL =SQL文
Set myConn = New ADODB.Connection
myConn.Open myConstr
Set myRs = New ADODB.Recordset
myRs.Open mySQL, myConn
Worksheets("シート名").Range("開始セル名").CopyFromRecordset myRs
myRs.Close
Set myRs = Nothing
myConn.Close
Set myConn = Nothing
Unload Me
End Sub
わかる方ご教授願います
No.11ベストアンサー
- 回答日時:
ANo.10です。
>下記でエラーします
>MsgBox "終了アドレス=
エラーの行は残したまま、エラーになる前の所に、
MsgBox "Fields.Count=" & myRs.Fields.Count
MsgBox "RecordCount=" & myRs.RecordCount
を入れてください。
どんな表示になりますか?
または、エラーが起こる場合は、どんなエラーですか?
または、ここではエラーが起こらず、MsgBox "終了アドレス="の所でエラーになる場合は、どんなエラーですか?
またはエラーの起こる、
MsgBox "終了アドレス=" & Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1).Address
の行の"ABC"と"F17"が全角になっていないか確認してください。
また、名前の定義がされていないか(Excel側で[挿入][名前]でABCやF17で名前が定義されていないか)も確認してください。
No.10
- 回答日時:
ANo.7です。
ANo.7の回答で、エラーの部分の命令は2度現れます。
1度目はコメントアウトにしてほしいと書いたのですが、削除して実行してください。
これは、この命令のどの部分がエラーを起こしているのか表示するために、その1文をコメントにして、各処理を分割して実行表示しているプログラムです。
そして、最後に同じ命令を行っています。(これがあればいいので)
説明の仕方が悪くてすみません。
myRs.Open mySQL, myConn, adOpenKeyset
Worksheets("ABC").Range...<-この行削除
Dim d() As Variant
....
Worksheets("ABC").Range(Worksheets("ABC").Range("F17"), Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
この回答への補足
お返事ありがとうございます
下記削除実行しました
Worksheets("ABC").Range...<-この行削除
下記でエラーします
MsgBox "終了アドレス=
よろしくおねがいます
No.9
- 回答日時:
すごい既回答ですが、ADOなら各レコードの各フィールドが捉えられるはずです。
これを1レコードの各フィールドを行ポインタ変数 i を持って+1して行方向(下方向)に流して代入し、レコードは列ポインタ j 持って、レコードが進むと、+1して列方向(右方向)に流して「フィールドごとに」セル(i,j)に代入すればよいと思うが。(この方法はコピー法ではない)
No.8
- 回答日時:
その他のコードは、書き換える必要はありません
これは、私が示したコードのことです。
Const 開始行 = 1
Const 開始列 = 1
Private Sub CommandButton1_Click()
Dim I As Integer
Dim N As Integer
Dim strEmployees() As String
strEmployees() = Split(DBSelect("質問者のSQL文"), ";")
N = UBound(strEmployees()) - 1
For I = 0 To N
Me.Cells(開始行, 開始列 + I) = strEmployees(I)
Next I
End Sub
これで、開始行の開始列から横にデータを表示します。
コピぺ方式だと縦に自動表示されます。
そういうエクセルの表示機能を使わずにVBAで横に表示する訳です。
strEmployees() = Split(DBSelect("質問者のSQL文"), ";")
N = UBound(strEmployees()) - 1
For I = 0 To N
Me.Cells(開始行, 開始列 + I) = strEmployees(I)
Next I
実質、僅か5行ですから、やっていることは理解できませんか?
<アドバイス>
このように僅か数行で目的を達成するには、作業を分割することです。
Accessからのデータの取得手続きは繰り返し発生するので、そこは関数に任せるのが一番。
CommandButton1_Click()では、関数から受け取ったデータを並べるだけに。
そうすると、何も考えないで2、3分でコードは書けます。
[イミディエイト]
? DBSelect("SELECT * FROM 担当者")
1;01: AAAA;True;True;2;02: BBBB;True;True;3;03: CCCC;False;True;
? DBSelect("SELECT * FROM 担当者",,vbcrlf)
1;01: AAAA;True;True;
2;02: BBBB;True;True;
3;03: CCCC;False;True;
では、一体、SQL文の実行結果をどのように受け取れば簡単に配列に取り込めるのかです。
それは、上述のように列と行とのデータを区切り子で区切った文字列として受け取ればいいです。
strEmployees() = Split(DBSelect("質問者のSQL文"), ";")
そうすりゃ、この1行で配列に取り込めます。
試しに、上の"質問者のSQL文"部分を正しく書いてコマンドボタンをクリックすりゃ表示されますよ。
<準備>
以下の関数を標準モジュールにコピペ。
もちろん、記号定数 pubCNNSTRING は、ちゃんと設定して下さい。
Public Const pubCNNSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\xxxx\xxxx.mdb"
Public Function DBSelect(ByVal strQuerySQL As String, _
Optional cel_separator As String = ";", _
Optional row_separator As String = "") As String
On Error GoTo Err_DBSelect
Dim I As Integer
Dim J As Integer
Dim R As Integer
Dim C As Integer
Dim M As Integer
Dim N As Integer
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim strList As String
Set rst = New ADODB.Recordset
With rst
.Open strQuerySQL, _
pubCNNSTRING, _
adOpenStatic, _
adLockReadOnly
If Not .BOF Then
M = .RecordCount - 1
N = .Fields.Count - 1
.MoveFirst
For R = 0 To M
C = -1
For Each fld In .Fields
C = C + 1
strList = strList & fld.Value & "" & cel_separator
Next fld
strList = strList & row_separator
.MoveNext
Next R
Else
strList = ""
End If
End With
Exit_DBSelect:
On Error Resume Next
rst.Close
Set rst = Nothing
DBSelect = strList
Exit Function
Err_DBSelect:
MsgBox "SELECT 文の実行時にエラーが発生しました。(DBSelect)" & Chr$(13) & Chr$(13) & _
"・Err.Description=" & Err.Description & Chr$(13) & _
"・SQL Text=" & strQuerySQL, _
vbExclamation, " 関数エラーメッセージ"
Resume Exit_DBSelect
End Function
この回答への補足
お返事ありがとうございます
現在上記標準モジュール作成(.mdb)のパス記載し
フォーム内
下記を記述し(SQL文作成)しました
Const 開始行 = 1
Const 開始列 = 1
Private Sub CommandButton1_Click()
Dim I As Integer
Dim N As Integer
Dim strEmployees() As String
strEmployees() = Split(DBSelect("質問者のSQL文"), ";")
N = UBound(strEmployees()) - 1
For I = 0 To N
Me.Cells(開始行, 開始列 + I) = strEmployees(I)
Next I
End Sub
上記実行すると
コンパイルエラー
メソッドまたはデータメンバが見つかりません。
とでます。
どこがいけないのでしょうか?
よろしくお願い申し上げます
No.7
- 回答日時:
エラーになる行をコメントアウトにして、それ以下でデータを表示してみます。
下記のようになるようにしてみてください。
どこでエラーになりますか?
ANo.5で変更して下記の部分
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
をコメントアウトして、それ以下を追加してみてください
'Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
Dim d() As Variant
d = myRs.GetRows
MsgBox "フィールド数=" & UBound(d, 1) + 1
MsgBox "レコード数=" & UBound(d, 2) + 1
MsgBox "A1に入るデータ=" & d(0, 0)
MsgBox "開始アドレス=" & Worksheets("シート名").Range("開始セル名").Address
MsgBox "終了アドレス=" & Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1).Address
MsgBox "コピー先範囲をselectしました"
Worksheets("シート名").Select
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)).Select
myRs.MoveFirst
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
p.s.
差し支えなければ、"開始セル名"を教えてください。
この回答への補足
お返事ありがとうございます
開始セル名はF17にしております
Private Sub CommandButton1_Click()
Dim myConn As ADODB.Connection
Dim myRs As ADODB.Recordset
Dim mySQL As String
Dim myConstr As String
Dim myDBFName As String
Dim myPswd As String
Dim tableName As String
Dim orderDate As String
Dim shipDate As String
orderDate = Format(DateValue(DTPicker1.Value), "mm/dd/yyyy")
shipDate = Format(DateValue(DTPicker2.Value), "mm/dd/yyyy")
myDBFName = "アクセスパス"
myPswd = ""
myConstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& myDBFName & ";Jet OLEDB:Database Password=" & myPswd & ";"
mySQL = "SELECT B.日付 FROM B " & _
"WHERE(((B.日付)>=#" & orderDate & "#) AND ((B.日付)<=#" & shipDate & _
"#));"
Set myConn = New ADODB.Connection
myConn.Open myConstr
Set myRs = New ADODB.Recordset
myRs.Open mySQL, myConn, adOpenKeyset
Worksheets("ABC").Range(Worksheets("ABC").Range("F17"), Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
Dim d() As Variant
d = myRs.GetRows
MsgBox "フィールド数=" & UBound(d, 1) + 1
MsgBox "レコード数=" & UBound(d, 2) + 1
MsgBox "A1に入るデータ=" & d(0, 0)
MsgBox "開始アドレス=" & Worksheets("ABC").Range("F17").Address
MsgBox "終了アドレス=" & Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1).Address
MsgBox "コピー先範囲をselectしました"
Worksheets("ABC").Select
Worksheets("ABC").Range(Worksheets("ABC").Range("F17"), Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)).Select
myRs.MoveFirst
Worksheets("ABC").Range(Worksheets("ABC").Range("F17"), Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
myRs.Close
Set myRs = Nothing
myConn.Close
Set myConn = Nothing
Unload Me
End Sub
エラーは
Worksheets("ABC").Range(Worksheets("ABC").Range("F17"), Worksheets("ABC").Range("F17").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
ここででます
よろしくお願いします
No.6
- 回答日時:
Q、下記のどの部分に記述すればよいのですか?
A、先のコードのSQL文を書き換えて開始行と開始列を指定するだけです。
その他のコードは、書き換える必要はありません。
X N = UBound(strEmployees())
O N = UBound(strEmployees())-1
と、チト、修正は必要ですが・・・。
つまり、Access からのデータ取得手続きは一切関数任せということです。
この回答への補足
ええ?
再確認ですが
下記修正しましたがつじつまがあわなくて
Private Sub CommandButton1_Click()
Dim myConn As ADODB.Connection
Dim myRs As ADODB.Recordset
Dim mySQL As String
Dim myConstr As String
Dim myDBFName As String
Dim myPswd As String
Dim tableName As String
Dim orderDate As String
Dim shipDate As String
orderDate = Format(DateValue(DTPicker1.Value), "mm/dd/yyyy")
shipDate = Format(DateValue(DTPicker2.Value), "mm/dd/yyyy")
myDBFName = "アクセスパス"
myPswd = ""
myConstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& myDBFName & ";Jet OLEDB:Database Password=" & myPswd & ";"
mySQL = "SELECT B.担当者 FROM B " & _
"WHERE(((B.日付)>=#" & orderDate & "#) AND ((B.日付)<=#" & shipDate & _
"#));"
Set myConn = New ADODB.Connection
myConn.Open myConstr
Set myRs = New ADODB.Recordset
myRs.Open mySQL, myConn, adOpenKeyset
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル"), Worksheets("シート名").Range("開始セル").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
myRs.Close
Set myRs = Nothing
myConn.Close
Set myConn = Nothing
Unload Me
End Sub
これで修正したら先ほどのエラーになります
N = UBound(strEmployees())-1
上記はどの部分で記述すればよいですか?
No.5
- 回答日時:
ANo.3とANo.4です。
たびたびすみません、下のようではどうでしょうか?
myRs.Open mySQL, myConn
を
myRs.Open mySQL, myConn, adOpenKeyset
に変更(myRs.RecordCountが-1にならないようにするため)
Worksheets("シート名").Range("開始セル名").CopyFromRecordset myRs
を
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
に変更
この回答への補足
お返事ありがとうございます
だめです
実行時エラー1004
アプリケーション定義またはオブジェクトの定義エラーです
になります
又、デバックは
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
に色がつきます
No.4
- 回答日時:
ANo.3です。
間違えました、下のようではどうでしょうか?
Set myRs = New ADODB.Recordset
を
myRs.Open mySQL, myConn, adOpenKeyset
に変更(myRs.RecordCountが-1にならないようにするため)
Worksheets("シート名").Range("開始セル名").CopyFromRecordset myRs
を
Worksheets("シート名").Range(Worksheets("シート名").Range("開始セル名"), Worksheets("シート名").Range("開始セル名").Offset(myRs.Fields.Count - 1, myRs.RecordCount - 1)) = myRs.GetRows
に変更
No.3
- 回答日時:
こんなのはどうでしょうか?
Set myRs = New ADODB.Recordset
を
myRs.Open mySQL, myConn, adOpenKeyset
に変更(myRs.RecordCountが-1にならないようにするため)
Worksheets("シート名").Range("開始セル名").CopyFromRecordset myRs
を
Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(1, 1), Worksheets("Sheet1").Cells(myRs.Fields.Count, myRs.RecordCount)) = myRs.GetRows
に変更
No.2
- 回答日時:
Const 開始行 = 1
Const 開始列 = 1
Private Sub CommandButton1_Click()
Dim I As Integer
Dim N As Integer
Dim strEmployees() As String
strEmployees() = Split(DBSelect("SELECT 担当者名 FROM 担当者"), ";")
N = UBound(strEmployees())
For I = 0 To N
Me.Cells(開始行, 開始列 + I) = strEmployees(I)
Next I
End Sub
<実行結果>
01: ○○ ○○__02: ○○ ○○__03: ○○ ○○
エクセルは操作したこともない門外漢ですが・・・。
一応、これでA1、A2、A3に取得したデータが表示されます。
For-Next文を使う初手の手法です。
この手法を使うには、一応、DBSelect関数の自作が必要です。
このような手法で構わなければ DBSelect関数を補足します。
この回答への補足
本当にうごきますか?
下記のどの部分に記述すればよいのですか?
Private Sub CommandButton1_Click()
Dim myConn As ADODB.Connection
Dim myRs As ADODB.Recordset
Dim mySQL As String
Dim myConstr As String
Dim myDBFName As String
Dim myPswd As String
Dim tableName As String
Dim orderDate As String
Dim shipDate As String
orderDate = Format(DateValue(DTPicker1.Value), "mm/dd/yyyy")
shipDate = Format(DateValue(DTPicker2.Value), "mm/dd/yyyy")
myDBFName = "Accessパス"
myPswd = ""
myConstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& myDBFName & ";Jet OLEDB:Database Password=" & myPswd & ";"
mySQL =SQL文
Set myConn = New ADODB.Connection
myConn.Open myConstr
Set myRs = New ADODB.Recordset
myRs.Open mySQL, myConn
Worksheets("シート名").Range("開始セル名").CopyFromRecordset myRs
myRs.Close
Set myRs = Nothing
myConn.Close
Set myConn = Nothing
Unload Me
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/07/15 15:12
- Visual Basic(VBA) ExcelからAccessのテーブルに書き込む時に時間がかかる 1 2022/10/14 20:38
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Visual Basic(VBA) access count数を変数に格納 2 2022/03/30 19:21
- Visual Basic(VBA) ExcelVBAに関する質問 3 2023/02/17 10:47
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 1 2023/08/08 15:45
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- Visual Basic(VBA) 別シートから年齢別の件数をカウントしたい 6 2023/01/23 12:00
- Visual Basic(VBA) 【VBA】先月分の取得ができない理由が分かりません。 2 2022/04/24 11:16
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excelの「0」だけ非表示、小数...
-
日付が未入力の際はゼロか、空...
-
エクセルで条件に一致したセル...
-
エクセルで1月0日と表示される!!
-
Excelでスクロールすると文字が...
-
別シートのセルを絶対参照にする
-
複数シートの同じセル内容を1シ...
-
Rangeメソッドは失敗しました。...
-
自動で複数セルの内容をシート...
-
シート参照で変数を使いたい(EX...
-
(Excel)あるセルに文字を入力...
-
エクセルで複写のように自動入...
-
VBAで、セル(Range)のオブジ...
-
Excelで複数シートの選択セルを...
-
Excelシートの保護時にデータの...
-
VBAで変数に関数式の結果をセッ...
-
エクセル ctrl+End いくら削...
-
エクセルで指定のセルのみ完全...
-
INDIRECTを使わず excelで複数...
-
エクセルで、加筆修正したセル...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルで条件に一致したセル...
-
Excelの「0」だけ非表示、小数...
-
日付が未入力の際はゼロか、空...
-
(Excel)あるセルに文字を入力...
-
エクセルで1月0日と表示される!!
-
別シートのセルを絶対参照にする
-
複数シートの同じセル内容を1シ...
-
Rangeメソッドは失敗しました。...
-
Excelシートの保護時にデータの...
-
エクセルで複写のように自動入...
-
Excelで複数シートの選択セルを...
-
シート参照で変数を使いたい(EX...
-
ExcelでTODAY関数を更新させな...
-
エクセル ハイパーリンクで画像...
-
エクセルで、加筆修正したセル...
-
エクセルのセルに、マウスで選...
-
EXCEL関数でシート名が変わる可...
-
VBAで、セル(Range)のオブジ...
-
Excelのファイル容量が減らない...
-
excelでハイパーリンクになって...
おすすめ情報