Sub testsetRecordSet2()
Dim targetPath As String
Dim targetPath2 As String
Dim strFileName As String
Dim targetFolderPath As String
Dim strSQL As String
Dim strSQL2 As String
Dim intIndex As Long
Dim dbFileName As String
Dim strName As String
Dim strColor As String
Dim strKind As String
Dim intPrice As Integer
Dim strErr As String
Dim intFileNumber As Integer
'読込元CSVファイルパス
' targetPath = "C:\デスクトップ\エラーあり.CSV"
targetPath = "C:\Users\cryst\OneDrive\デスクトップ\郵便csv\エラーなし.csv"
’dbファイルパス
dbFileName = "蔵書4-11 - コピー.accdb"
'フルパスからファイル名を取得
strFileName = Dir(targetPath)
'フルパスからフォルダ名を取得
targetFolderPath = Replace(targetPath, strFileName, "")
'---------------------------------------------------------------
'ADODBを遅延バインディングするときの書き方
Dim CN As Object
Dim CN2 As Object
Dim RS As Object
Dim RS2 As Object
Dim RS3 As Object
Set CN = CreateObject("ADODB.Connection")
Set CN2 = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.Recordset")
Set RS2 = CreateObject("ADODB.Recordset")
Set RS3 = CreateObject("ADODB.Recordset")
'---------------------------------------------------------------
'参照設定済のときの書き方
'Dim CN As ADODB.Connection
'Dim RS As ADODB.Recordset
'-----------------------------------------------------------------------
'OSが64bitの場合はJET.OLEDB.4.0;は使用できなくなったのでACE.OLEDB.12.0;
'接続先を指定（CSVのフォルダパスを指定）
CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & targetFolderPath & ";" & _
"Extended Properties='Text;HDR=NO'"
'接続先を指定（Accessアプリファイル）
CN2.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & CurrentProject.Path & "\" & dbFileName & ";"
'-----------------------------------------------------------------------
'SQL文作成（FROM以降はCSVのファイル名）
strSQL = "SELECT * FROM " & strFileName
'SQLを実行してレコードセットに格納
RS.Open strSQL, CN
'レコードセットの行番号を初期化
intIndex = 0
'CSVエラーチェック
Do Until RS.EOF
'項目名以降の行をチェック
If intIndex <> 0 Then
strName = Nz(RS(0), "ブランク")
strColor = Nz(RS(1), "ブランク")
strKind = Nz(RS(2), "ブランク")
intPrice = Nz(RS(3), 0)
'エラーチェックFunctionに飛び、エラーチェックメッセージを取得
strErr = checkErr(strErr, intIndex, strName, strColor, strKind, intPrice)
End If
'行番号に１足す
intIndex = intIndex + 1
'次のレコードへ移動
RS.MoveNext
Loop
'エラーメッセージ有の場合
If strErr <> "" Then
'エラーリストCSVを作成
targetPath2 = CreateErrListCsv
'エラーリストCSVにエラーメッセージを書き込み
intFileNumber = FreeFile
Open targetPath2 For Output As #intFileNumber
Print #intFileNumber, strErr
Close #intFileNumber
'エラーリストCSVを表示する
Shell "NOTEPAD.EXE " & Chr(34) & targetPath2, 1
Else
'SQL文実行してテーブルのレコードを全件削除
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM T_テスト用"
DoCmd.SetWarnings True
'SQL文を実行してテストテーブルをレコードセットに格納
strSQL2 = "SELECT * FROM T_テスト用"
RS2.Open strSQL2, CN2, 2, 2
'レコードセットRSのカーソルが最終行にあるため、
'一旦RSを開放してRS3にCSVデータを格納しなおす。
'RSのカーソルのみ移動しても、一度抜けた一番最初のループに戻ってしまうため
RS.Close
Set RS = Nothing
RS3.Open strSQL, CN
'行番号を初期化
intIndex = 0
'テストテーブルにCSVデータを挿入
Do Until RS3.EOF
'項目名以降を処理
If intIndex <> 0 Then
RS2.AddNew
RS2("名前") = RS3(0)
RS2("色") = RS3(1)
RS2("種類") = RS3(2)
RS2("値段") = RS3(3)
RS2.Update
End If
'行番号に１を足す
intIndex = intIndex + 1
RS3.MoveNext
Loop
MsgBox "CSVデータをテーブルにインポート完了しました。"
End If
EndProc:
'RSについては上の方で既にクローズ、開放済
If strErr = "" Then
RS2.Close
RS3.Close
End If
CN.Close
CN2.Close
Set RS2 = Nothing
Set RS3 = Nothing
Set CN = Nothing
Set CN2 = Nothing
End Sub
'----------------------------------------------------------------------------------------------------------------------
Function checkErr(strErr As String, intIndex As Long, strName As String, strColor As String, strKind As String, intPrice As Integer) As String
Dim strMessage As String
strMessage = strErr
If strName = "ブランク" Then
strMessage = strMessage & intIndex & "行目:名前の入力がありません。" & vbCrLf
End If
If strColor = "ブランク" Then
strMessage = strMessage & intIndex & "行目:色の入力がありません。" & vbCrLf
End If
If strKind = "ブランク" Then
strMessage = strMessage & intIndex & "行目:種類の入力がありません。" & vbCrLf
ElseIf strKind = "野菜" Then
strMessage = strMessage & intIndex & "行目:種類が野菜です。" & vbCrLf
End If
If intPrice = 0 Then
strMessage = strMessage & intIndex & "行目:値段の入力がありません。" & vbCrLf
ElseIf intPrice >= 500 Then
strMessage = strMessage & intIndex & "行目:値段が500円以上です。" & vbCrLf
End If
checkErr = strMessage
End Function
