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
’dbファイルパス
dbFileName = "蔵書4-11 - コピー.accdb"
strFileName = Dir(targetPath)
targetFolderPath = Replace(targetPath, strFileName, "")
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")
CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & targetFolderPath & ";" & _
"Extended Properties='Text;HDR=NO'"
CN2.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & CurrentProject.Path & "\" & dbFileName & ";"
strSQL = "SELECT * FROM " & strFileName
RS.Open strSQL, CN
intIndex = 0
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)
strErr = checkErr(strErr, intIndex, strName, strColor, strKind, intPrice)
End If
intIndex = intIndex + 1
RS.MoveNext
Loop
If strErr <> "" Then
targetPath2 = CreateErrListCsv
intFileNumber = FreeFile
Open targetPath2 For Output As #intFileNumber
Print #intFileNumber, strErr
Close #intFileNumber
Shell "NOTEPAD.EXE " & Chr(34) & targetPath2, 1
Else
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM T_テスト用"
DoCmd.SetWarnings True
strSQL2 = "SELECT * FROM T_テスト用"
RS2.Open strSQL2, CN2, 2, 2
RS.Close
Set RS = Nothing
RS3.Open strSQL, CN
intIndex = 0
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:
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