accessファイルの abc.mdbのtable1のフィールド1のIDの数値を
現在開いているエクセルファイル Q.xlsxの
A2セルに移行したいのですが
エクセルのVBAにおいて
Sub IDエクセルへ移行()
'
'Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim mySQL As String
Dim dbFile As Variant
Dim mySheetName As Variant
Dim i As Integer
dbFile = "C:\Users\USER\Desktop\ABC\abc.mdb"
myCon.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & dbFile & ""
myCon.Open
mySQL = "SELECT * FROM table1"
myRecordSet.Open mySQL, myCon, adOpenDynamic
mySheetName = ActiveSheet.Name
With Worksheets(mySheetName)
.Cells(1, 2).Value = myRecordSet!ID
End With
myRecordSet.Close
Set myRecordSet = Nothing
myCon.Close
Set myCon = Nothing
'
'
ActiveWorkbook.Save
End Sub
-------------
上記を実行すると
objectがありません
と
myCon.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & dbFile & ""
ここの部分が黄色くなってしまいます
ここが さっぱり意味不明です
すみません
宜しくお願い致します
Microsoft ActiveX Data Objects 2.8 Library 6.1も
参照設定で チェックを入れました
win10 office365
office365
２つのオートシェープをグルーピングして図形を動作させたい
下記で
kibanは平行四辺形のオートシェープ
yajirushiは右向き矢印のオートシェープ
で、それぞれ、ある範囲で左から右に移動を繰り返します。
この２つのオートシェープをグルーピングして
平行四辺形の右側に矢印を配置した状態で、そのグルーピングされた図形の動作を繰り返す様にしたいのですが、
その内容が分からないのでコードで教えていただきたく、よろしくお願いします。
#If Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
' Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub kiban()
shape_delete
Dim ws2 As Worksheet
Dim i As Integer
Set ws2 = Sheets("sheet1")
ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 354, 46, 20).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 458, 20, 20).Select
ws2.Shapes(ws2.Shapes.Count).name = "kiban"
For i = 0 To 30
If i = 30 Then
i = 0
End If
ws2.Shapes(1).Left = i * 3 + 365
ws2.Shapes(1).Top = 458
Sleep 100
DoEvents
Next i
ws2.Shapes("kiban").delete
End Sub
Sub yajirushi()
shape_delete
Dim ws As Worksheet
Dim i As Integer
Set ws = Sheets("sheet1")
ws.Shapes.AddShape msoShapeRightArrow, 2265, 458, 20, 20
ws.Shapes(ws.Shapes.Count).name = "yajirushi"
For i = 0 To 30
If i = 30 Then
i = 0
End If
ws.Shapes(1).Left = i * 3 + 420
ws.Shapes(1).Top = 458
Sleep 100
DoEvents
Next i
ws.Shapes("yajirushi").delete
End Sub
Sub shape_delete()
Dim shp As Shape
Dim rng As Range
Range("P22:CM28").Select
If TypeName(Selection) <> "Range" Then Exit Sub
For Each shp In ActiveSheet.Shapes
'‘ 図形の配置されているセル範囲をオブジェクト変数にセット
Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)
'‘ 図形の配置されているセル範囲と
'‘ 選択されているセル範囲が重なっているときに図形を削除
If Not (Intersect(rng, Selection) Is Nothing) Then
shp.delete
End If
Next
End Sub
複数のテキストファイルを各シート毎にエクセルマクロを用いて貼りつけたいです。
【テキストの内容】
AAA BBB CCC DDD・・・
EEE FFF GGG HHH・・・
III JJJ KKK LLL・・・
・
・
・
上記のようなようなデータが書かれた複数のテキストファイルを各シート毎に張り付けるマクロを探していたところ
下記のようなものを見つけました。
しかし、
マクロを動かした所、一つのセルに一行分が入ってしまいます。
例)セルA1に
AAA BBB CCC DDDが貼り付けられてしまう
セルA2に
EEE FFF GGG HHHが貼り付けられてしまう
可能であればスペース区切りでセルA、セルB、セルCに分けたいです。
例)セルA1に
AAAが貼り付けられる
セルB1に
BBBが貼り付けられる
セルC2に
CCCが貼り付けられる
スペース区切りで張り付けらる方法をご教示ください。
===========================
Sub ReadTextFiles()
Const DirName = "C:\TEMP"
'上記で指定されたフォルダに存在するファイルで、
'拡張子がtxtのものをすべて１シートとして読み込む
Dim fs, dir, fc, f1, stream As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set dir = fs.GetFolder(DirName)
Set fc = dir.Files
For Each f1 In fc
If LCase(fs.GetExtensionName(f1.Name)) = "txt" Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = f1.Name
Set stream = f1.OpenAsTextStream
Do While stream.AtEndOfStream <> True
Cells(stream.Line, 1) = stream.ReadLine
Loop
stream.Close
End If
Next
End Sub
===========================
標記の件。
不明な点がありご教授頂きたくお願い致します。
今まで普通に使えていたのですが急にエラー「実行時エラー2147467259・（80004005）エラーを特定できません」が出るようになりました。
Windowsのヘルプを参照しましたが、全然ヘルプどころか謎が深まるばかりという状況です。
2つあるチェックボックスの2つ目でエラーになります。
下記コードで全体の改善点含め原因等ありましたらご教授をお願い致します。クエリに変更はありませんでした。
Private Sub btn_登録_Click()
Dim con As ADODB.Connection
Dim rst As ADODB.Recordset
Set con = CurrentProject.Connection
Set rst = New ADODB.Recordset
If IsNull(txt_工数ﾛｯﾄCD = "" Or _
txt_部品CD = "" Or _
txt_図面番号 = "" Or _
txt_数量 = "" Or _
txt_品名 = "" Or _
cmb_社員名 = "" Or _
txt_作業日 = "" Or _
cmb_工程 = "" Or _
txt_工数 = "") Then
MsgBox " 未入力項目があります", vbCritical, "確認"
Exit Sub
End If
If txt_工数ﾛｯﾄCD = "" Or _
txt_部品CD = "" Or _
txt_図面番号 = "" Or _
txt_数量 = "" Or _
txt_品名 = "" Or _
cmb_社員名 = "" Or _
txt_作業日 = "" Or _
cmb_工程 = "" Or _
txt_工数 = "" Then
MsgBox "未入力項目が有ります", vbCritical, "確認"
Exit Sub
End If
rst.Open "Q_工程進捗確認", con, adOpenForwardOnly, adLockPessimistic
On Error GoTo err_handler 'エラーなら
con.BeginTrans '
With rst
.AddNew
.Fields("工数ﾛｯﾄCD") = Me!txt_工数ﾛｯﾄCD
.Fields("部品CD") = Me!txt_部品CD
.Fields("数量") = Me!txt_数量
.Fields("社員名") = Me!cmb_社員名
.Fields("作業日") = Me!txt_作業日
.Fields("工程") = Me!cmb_工程
.Fields("工数") = Me!txt_工数
If IsNull(Me.chk_自工程完了) Then
.Update
Else
.Fields("自工程完了") = Me.chk_自工程完了
.Update '更新
End If
If IsNull(Me.chk_製作完了) Then
.Update '更新
Else
.Fields("製作完了") = Me.chk_製作完了.Value ←ここでエラー
.Update
End If
End With
con.CommitTrans '確定
Set rst = Nothing
Set con = Nothing
Call btn_クリア_Click
Exit Sub
err_handler:
con.RollbackTrans
Call dbcut_off
MsgBox Error$
Debug.Print Error$
End Sub
