Microsoft Access 掲示板

Function ImportOrderRecords(SourceBookPath As String, SourceSheetName As String)
On Error GoTo Err_ImportOrderRecords

    Const OrderDateCellAddress As String = "B2"
    Const OrderDateSuffix As String = "依頼分"
    Const HeaderRow As Long = 4
    Const KeyColumn As Long = 2
    Const DestinationTableName As String = "T_インポートテーブル"

    ImportOrderRecords = Null

    Dim xlsApp As Object        'Excel.Application
    Dim xlsBook As Object       'Excel.Workbook
    Dim xlsWorksheet As Object  'Excel.Worksheet

    Set xlsApp = CreateObject("Excel.Application")

    Set xlsBook = xlsApp.Workbooks.Open(FileName:=SourceBookPath, ReadOnly:=True)
    Set xlsWorksheet = xlsBook.Worksheets(SourceSheetName)

    Dim varOrderDate As Variant
    Dim lngSuffixPostion As Long

    With xlsWorksheet.Range(OrderDateCellAddress)
        
        varOrderDate = .Value
        lngSuffixPostion = InStrRev(varOrderDate, OrderDateSuffix, -1, vbTextCompare)
        
        If lngSuffixPostion > 0 Then
            varOrderDate = Trim(Left(varOrderDate, lngSuffixPostion - 1))
        End If
        
        If IsDate(varOrderDate) = True Then
            varOrderDate = CDate(varOrderDate)
        Else
            Debug.Print .Address(False, False) & " セルの値: "
            Debug.Print .Value
            MsgBox .Address(False, False) & " セルから依頼日を参照できません。", _
                   vbExclamation, _
                   "ImportOrderRecords"
            Set xlsWorksheet = Nothing
            xlsBook.Close False
            Set xlsBook = Nothing
            xlsApp.Quit
            Set xlsApp = Nothing
            Exit Function
        End If

    End With

    Dim lngFirstDataRow As Long
    Dim lngLastDataRow As Long

    With xlsWorksheet
        
        lngFirstDataRow = HeaderRow + 1
        lngLastDataRow = .Cells(.Rows.Count, KeyColumn).End(xlUp).Row
        
        If lngFirstDataRow > lngLastDataRow Then
            MsgBox "ワークシート[" & .Name & "]からデータ行を参照できません。", _
                   vbExclamation, _
                   "データ参照エラー (ImportOrderRecords)"
            Set xlsWorksheet = Nothing
            xlsBook.Close False
            Set xlsBook = Nothing
            xlsApp.Quit
            Set xlsApp = Nothing
            Exit Function
        End If
        
    End With

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strSQL As String

    Set db = CurrentDb

    strSQL = "DELETE * FROM [" & DestinationTableName & "]"
    Debug.Print strSQL
    db.Execute strSQL, dbFailOnError

    strSQL = "SELECT * FROM [" & DestinationTableName & "]"
    Debug.Print strSQL

    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)

    Dim lngDataRow As Long
    Dim lngInsertCount As Long

    For lngDataRow = lngFirstDataRow To lngLastDataRow
        rs.AddNew
        rs![依頼日].Value = varOrderDate
        With xlsWorksheet.Cells(lngDataRow, KeyColumn)
            rs![社名ID].Value = .Value
            rs![商品名1].Value = .Offset(0, 4).Value
            rs![商品名2].Value = .Offset(0, 5).Value
            rs![商品名3].Value = .Offset(0, 6).Value
            rs![商品名4].Value = .Offset(0, 7).Value
        End With
        rs.Update
        lngInsertCount = lngInsertCount + 1
        Debug.Print lngInsertCount & " 件目のレコードを取り込みました。"
    Next

    ImportOrderRecords = lngInsertCount

Exit_ImportOrderRecords:
On Error Resume Next

    Set rs = Nothing
    Set db = Nothing

    Set xlsWorksheet = Nothing

    If Not xlsBook Is Nothing Then
        xlsBook.Close False
        Set xlsBook = Nothing
    End If

    If Not xlsApp Is Nothing Then
        xlsApp.Quit
        Set xlsApp = Nothing
    End If

    Exit Function

Err_ImportOrderRecords:

    Dim strErrMsg As String

    strErrMsg = Err.Number & ": " & Err.Description

    MsgBox strErrMsg, _
           vbCritical, _
           "実行時エラー (ImportOrderRecords)"

    Resume Exit_ImportOrderRecords
End Function