Access (VBA)

Access VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
Excel2010の複数シートを一括インポートしたい(シート名称に基づき取込み対象シートを絞り込み)
投稿日時: 18/11/21 11:52:20
投稿者: Kazyu_A

Kazyu_Aと申します。
   
  
このたび、
件名のとおり、
「Excel2010の複数シートを一括インポートする(シート名称に基づき取込み対象シートを絞り込み)」
という要件を実現するため、
Access VBAでの仕組み構築を試みております。
  
ネット上で、他者様のご質問・ご回答を探して参考にさせていただき、
シート名称、セル範囲を個別に指定して、1シートのみを取り込むことはできました。
   
しかしながら、
「Dim I as Integer
  For I = 1 to 9999」という変数定義を加えて、
取り込み対象のエクセルシート名称が、1〜9999の範囲内である旨を規定しようとしたところで、
「forに対応するnextがありません」というエラーが出てしまっております。 
   
本VBAに関して
残りの課題を改めて記述させていただくと、下記となります。
   
「エクセルのシート名称が、半角数字で1〜9999のいずれかに該当する場合、
 該当するすべてのシートを取込対象シートとみなして一括取り込みする。
(各シート内の取込み範囲はD5:P200で共通)」
   
下記にて、現状の式を記載させていただきますので、
エラーを解消しつつ、上記の要件を実現するために、どこをどう変えればよいものか、
何卒ご指導のほど、よろしくお願い申し上げます。
-----------------------------------------------------------------
Private Sub コマンド1_Click()
On Error GoTo エラー
   
    Dim strac As String
    Dim strxls As String
    Dim I As Integer
        For I = 1 To 9999
    Dim strrange As String
    Dim strmsg As String
   
    strac = "申請集計" 'Accessテーブルを指定
    strxls = "C:\Users\Keiri1.SDKNET1\Documents\取込\申請フォーム.xlsx" '取込対象のエクセルブックを指定
    strrange = "I!D5:P200" 'データ入力のシート名とセル範囲を指定
    strmsg = "エクセルファイル" & strxls & " を、Accessファイル " & strac & _
             "として、データ入力を行います。" & Chr(13) & Chr(13) & _
             "エクセルファイルの入力範囲は、 " & strrange & " です。" 'MsgBoxのメッセージです。
     If MsgBox(strmsg, vbOKCancel, "Microsoft Access Club") = vbOK Then
        '最初の行はフィールド名として取込む。
        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, _
                                        strac, strxls, True, strrange
           
        MsgBox "データ入力は、正常に完了しました。"
    End If
    Exit Sub
   
エラー:
    Select Case Err.Number
        Case 7874
            'エラーの原因となったステートメントの、
            '次のステートメントからプログラムの実行を再開する。
            Resume Next
        Case Else
            MsgBox "予期せぬエラーが発生しました。" & Chr(13) & Chr(13) & _
                   "エラー番号:" & Err.Number & Chr(13) & Chr(13) & _
                   "エラー内容:" & Err.Description, 1, "Microsoft Access Club"
            End
        End Select
    End Sub
Sub 取込み()
End Sub

回答
投稿日時: 18/11/21 15:54:54
投稿者: sk

引用:
「Dim I as Integer
  For I = 1 to 9999」という変数定義を加えて、
取り込み対象のエクセルシート名称が、1〜9999の範囲内である旨を規定しようとしたところで、
forに対応するnextがありません」というエラーが出てしまっております。

・メッセージの通り、For(ループブロックの始まり) に対応する
 Next(ループブロックの終わり)が記述されていない。
 
・それ以前に、そこに For 文を記述するべきではない
 
引用:
「エクセルのシート名称が、半角数字で1〜9999のいずれかに該当する場合、
 該当するすべてのシートを取込対象シートとみなして一括取り込みする。
(各シート内の取込み範囲はD5:P200で共通)」

(フォームモジュール)
-----------------------------------------------------------------
Private Sub コマンド1_Click()
On Error GoTo Err_コマンド1_Click
    
    Dim strDestinationTableName As String
    Dim strSourceBookName As String
    Dim strSourceRange As String
    Dim strMsg As String
    Dim varItem As Variant
    Dim objSheets As Object
    
    strDestinationTableName = "申請集計"
    strSourceBookName = "C:\Users\Keiri1.SDKNET1\Documents\取込\申請フォーム.xlsx"
     
    strMsg = "'" & strSourceBookName & "'内のワークシートを、" & _
             "テーブル[" & strDestinationTableName & "]としてインポートします。"
      
    If MsgBox(strMsg, vbOKCancel, "実行確認") = vbCancel Then
        Exit Sub
    End If
     
    Set objSheets = GetImportSheetList(strSourceBookName)
    If objSheets Is Nothing Then
        Exit Sub
    End If
     
    For Each varItem In objSheets
        strSourceRange = varItem & "D5:P200"
        Debug.Print strSourceRange & " をインポートします"
        DoCmd.TransferSpreadsheet acImport, _
                                  acSpreadsheetTypeExcel12Xml, _
                                  strDestinationTableName, _
                                  strSourceBookName, _
                                  True, _
                                  strSourceRange
    Next
     
    MsgBox "ワークシートのインポートが完了しました。", _
           vbInformation, _
           "実行完了"
     
Exit_コマンド1_Click:
On Error Resume Next
     
    Set objSheets = Nothing
     
    Exit Sub
    
Err_コマンド1_Click:
     
    strMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
             "エラー番号:" & Err.Number & vbCrLf & _
             "エラー内容:" & Err.Description
    Debug.Print strMsg
    MsgBox strMsg, _
           vbCritical, _
           "実行時エラー(" & Me.Name & ".コマンド1_Click)"
    Resume Exit_コマンド1_Click
End Sub
 
Private Function GetImportSheetList(ByVal WorkbookPath As String) As Object
On Error GoTo Err_GetImportSheetList
 
    Dim objRegExp As Object
     
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
     
    Dim strSheetName As String
    Dim clcSheets As Collection
    Dim strMsg As String
     
    If Dir(WorkbookPath) = "" Then
        MsgBox "'" & WorkbookPath & "'が見つかりません。", _
               vbExclamation, _
               "エラー"
        Exit Function
    End If
     
    Set objRegExp = CreateObject("VBScript.RegExp")
    With objRegExp
        .Pattern = "^['][0-9]{1,4}[$][']$"
        .IgnoreCase = True
        .Global = True
    End With
     
    Set db = DBEngine.OpenDatabase(WorkbookPath, False, True, "Excel 12.0;HDR=NO;")
     
    For Each tdf In db.TableDefs
        strSheetName = ""
        If objRegExp.Test(tdf.Name) Then
            strSheetName = tdf.Name
            strSheetName = Mid(Left(strSheetName, Len(strSheetName) - 2), 2) & "!"
            Debug.Print strSheetName
        End If
         
        If strSheetName <> "" Then
            If clcSheets Is Nothing Then
                Set clcSheets = New Collection
            End If
            clcSheets.Add strSheetName
        End If
    Next
           
    If clcSheets Is Nothing Then
        MsgBox "インポート対象となるワークシートがありません。", _
               vbExclamation, _
               "エラー"
    Else
        Set GetImportSheetList = clcSheets
    End If
           
Exit_GetImportSheetList:
On Error Resume Next
       
    Set tdf = Nothing
    db.Close
    Set db = Nothing
    Set objRegExp = Nothing
     
    Exit Function
     
Err_GetImportSheetList:
 
    Set clcSheets = Nothing
     
    strMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
             "エラー番号:" & Err.Number & vbCrLf & _
             "エラー内容:" & Err.Description
    Debug.Print strMsg
    MsgBox strMsg, _
           vbCritical, _
           "実行時エラー(" & Me.Name & ".GetImportSheetList)"
     
    Resume Exit_GetImportSheetList
End Function
-----------------------------------------------------------------

回答
投稿日時: 18/11/21 16:17:33
投稿者: sk

補足:

引用:
エクセルのシート名称が、半角数字で1〜9999のいずれかに該当する場合

引用:
With objRegExp
    .Pattern = "^['][0-9]{1,4}[$][']$"
    .IgnoreCase = True
    .Global = True
End With

このパターンだと 0 や 0000 なども含まれてしまうので、
次のように記述した方がよいかも知れません。
 
-----------------------------------------------------
 
With objRegExp
    .Pattern = "^['][1-9][0-9]{0,3}[$][']$"
    .IgnoreCase = True
    .Global = True
End With
 
-----------------------------------------------------

投稿日時: 18/11/21 17:29:43
投稿者: Kazyu_A

SK様
お世話になります。
 
教えていただいたコードを使用してみましたところ、
希望するとおりに動きました。
複数回、取込みテストを実施しましたが、
問題ありませんでした。
 
毎半期、大量のエクセル集計処理で、数時間を要していたところ、
これで負担が緩和されます。
私自身の作業ではありませんが、後輩が喜ぶ顔が目に浮かびます。
 
本当にありがとうございました。
 
Kazyu_A