Microsoft Access 掲示板

フォームからExcelファイルの一部分をインポートしたい / 9

27 コメント
views
9
PPP 2025/07/14 (月) 21:49:04 修正 50473@7267b >> 7

とりあえず作成したソースコードを記載します。
SQLのCREATE TABLE文で作成したアクセスファイルに
フォームを作成してコマンドボタンを1個配置して
以下のソースコードを貼付けください

コンボBOX名はcmb01
テキストボックス名は、txb_発注者
コマンドボタン名は、btn01
コンボBOXに登録するテーブルも作成します
テーブル名はtb
フィールド名は2項目
フィールド名 ID、オートナンバー型
フィールド名 フィールド1 短いテキスト

|IDフィールド1|
1AA
2BB
3cc

集合値ソース:SELECT tb.ID, tb.[フィールド1] FROM tb;

これらの設定を行ったフォームがあれば、あとは取込みたい
エクセルを用意すれば、取込みができます。

通報 ...
  • 14
    PPP 2025/07/14 (月) 22:04:17 修正 50473@7267b >> 9

    コードが多いので分割して投稿します
    分かりやすくすために番号を振っておきます
    (1)VBAのコードのOption Compare Database、Option Explicit
    が記載されている上部に記載するコードです。
    フォーム内で共通で使用する共通変数をこの領域に記載します

    Option Compare Database
    Option Explicit
        '※事前にVBエディターのツルーバーにある「ツール」をクリックして
        '[参照設定]のメニューを開き
        '参照可能なライブラリーから
        '[Microsoft Office 16.0 Object Library]にレ点のチエックを入れる
        'これをしないとファイルダイアログボックスは開かれるエラーになる
        'パスを指定する
        
        'VBエディターのツールバーにある
        '「ツール」の参照設定から
        '「Microsoft Excel XX.X Object Library」
        'にレ点をいれる XX.Xは各PCのバージョンに合わす
    
        'コマンドボタンをクリックするイベントプロシージャーから
        '取得した変数データをCALLプロシージャーへ渡すため
        '共通変数としてここに宣言する
    
        'ダイアログBOXで開く場所のパスを代入する変数と
        'ファイル名を変更するときにファイルパスを取得する変数の
        '2つの変数を代入させるため配列変数で宣言
        Dim path(2) As String
        
        'エクセルのファイルを指定したパスを代入する変数
        Dim vrtSelectedItem As Variant
    
        'エクセル番地[A1]の値を代入
         Dim myNo As Long
    
        'エクセル番地[H2]の値を代入
         Dim myOrderNo As Long
    
        'セル番地[A11]の[No]の値を保有させる変数
        Dim cells_No As Long
        
      ’ここまでが共通変数を宣言した部分となります
    
  • 16

    (2)フォームに挿入したコンボBOXのイベントプロシージャです
    コンボBOX名は[cmb01]です

    'コンボボックスを更新したときのプロシージャー
    Private Sub cmb01_AfterUpdate()
            
            'テキストBOXにコンボボックスの値を代入するときは
            'テキストBOXの[Value]プロパティを指定する
            Me.txb_発注者.Value = Me.cmb01.Column(1)
            
            'ラベルにコンボボックス値を代入すときは
            'ラベルの[Caption]プロパティを指定する
            Me.lblNO.Caption = Me.cmb01.Column(1)
               
    End Sub
    
  • 17
    PPP 2025/07/14 (月) 22:12:48 修正 50473@7267b >> 9

    (3)コマンドボタンを押したときの処理です
    ここからが本題となります。

    'エクセルを取り込みためのボタンをクリックしたときのイベントプロシージャー
    Private Sub btn01_Click()
            
        'コンボボックスの値を選択しているかの確認
        If Me.cmb01.Value = "" Or IsNull(Me.cmb01) Then
            
            MsgBox ("コンボボックスの値を選択してください")
            
            'コンボボックスにフォーカスを移す
            Me.cmb01.SetFocus
            'コンボボックスをドロップダウンさせる
            Me.cmb01.Dropdown
            
            Exit Sub
            
        End If
        
        'FileDialogオブジェクトを宣言する
        Dim myOrderFile As FileDialog
            ' FileDialogオブジェクトを生成
            Set myOrderFile = Application.FileDialog(msoFileDialogOpen)
    
    
            '開く場所を指定(例:C:\Users\)
            '実際はエクセルデータがあるパスを代入する
            path(0) = "C:\Users\"
            
                'InitialFileNameプロパティにパスを設定
                myOrderFile.InitialFileName = path(0)
    
    
                'ダイアログのタイトルを設定
                myOrderFile.Title = "受注情報を取り込むエクセルファイルを選択してください"
    
                    'フィルタを設定(例:エクセルファイル表示)
                    myOrderFile.Filters.Clear
                    myOrderFile.Filters.Add "テキストファイル", "*.xlsx"
        
                    '慣れるとWithステートメント句で以下の様に省略して記述できる
                    'With myOrderFile.Filters
                        '.Clear
                        '.Add "テキストファイル", "*.xlsx"
                    'End With
    
            'ダイアログを表示
            '-1はOKボタンが押されたことを示す
            If myOrderFile.Show = -1 Then
            
                ' 選択されたファイルパスを取得
                For Each vrtSelectedItem In myOrderFile.SelectedItems
                    
                    'エクセルファイルのフルパスを代入する
                    path(1) = vrtSelectedItem
                    Debug.Print vrtSelectedItem
                
                    'ここで選択されたファイルパスを使って取り込みの
                    '処理を記載する
                   
                        Open vrtSelectedItem For Input As #1
                   
                            'ADO経由でエクセルデータを取り込む
                            'Callプロシージャーでエクセルデータを開き、セルのデータ内容を取得する
                            Call callExceltable
                            
                            'ファイルを開くときに使用した変数を閉じる
                            '閉じる処理をしないとファイルがロックされたままになるので注意
                            Close #1
                
                    Next vrtSelectedItem
        
            Else
            
                    ' キャンセルボタンが押された場合
                    MsgBox ("ファイル選択がキャンセルされました。")
        
            End If
    
                    Dim pos As Long
                        '[\]の位置を検索
                        pos = InStr(1, path(1), "\")
            
                    'パスを取得する変数
                    'エクセルファイル名より前の
                    'パスの文字列を取得
                    Dim firstCharacter As String
                    
                    'ルートパスのみの文字列を取得する
                    firstCharacter = Left(path(1), pos)
                
                        '[\]が見つかった場合
                        If pos > 0 Then
                
                        Dim result As String
                            '[\]の次の文字から最後まで抽出
                            result = Mid(path(1), pos + 1)
                   
                    
                            'ファイル名を変える式
                            'Name oldpathname As newpathname
                            Name path(1) As firstCharacter & "取り込み済み" & result
                    End If
            
                    'FileDialogオブジェクトを解放する
                    Set myOrderFile = Nothing
            
    
    End Sub
    
    
  • 18
    PPP 2025/07/14 (月) 22:17:48 修正 50473@7267b >> 9

    (4-1)長いので(4-1)と(4-2)(4-3)に分割して投稿します
    ※4-1)の部分は変数の宣言部分となります

    'エクセルファイルをACCESSのテーブルにとりこむための
    'コールプロシージャー
    Private Sub callExceltable()
    On Error Resume Next
    
        'エクセルのアプリケーションをNewキーワードで実体化(インスタンス化)する
        Dim myXlApp As Excel.Application
            Set myXlApp = New Excel.Application
      
        'エクセルのワークブックを
        '共通変数[vrtSelectedItem]で取得した取りこみするエクセルを
        '選択してオブジェクトを生成する
        Dim myXlWorkbook As Excel.Workbook
            Set myXlWorkbook = myXlApp.Workbooks.Open(vrtSelectedItem)
        
        'エクセルのワークシートを生成する
        'Sheet1のワークシートを指定して読み込む準備を整える
        Dim myXlWorksheet As Excel.Worksheet
            Set myXlWorksheet = myXlWorkbook.Sheets("Sheet1") '読み込むシート名を指定
            
        'エクセルの最終行の値を取得する変数
        Dim myLastRow As Long
        
            'エクセルシート入力している最終行を取得
            'セル番地[A]に入力している最終行を取得して変数へ代入する
            myLastRow = myXlWorksheet.Cells(myXlWorksheet.Rows.Count, "A").End(xlUp).Row
    
        '※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
        '番地は固定
        
            'エクセル番地[A1]の値を代入
            myNo = myXlWorksheet.Cells(1, 1).Value
        
            'エクセル番地[H2]の値を代入(発注番号)
           myOrderNo = myXlWorksheet.Cells(2, 8).Value
        
        '※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
            
            'ADO経由で取り込みテーブルにエクセルデータを転記する
            'VBエディターのツールの参照設定で
            'microsoft ActivX Data object 6.1llibraryにレ点を入れる
            
            'ADOの接続のオブジェクトの宣言を行う
            Dim cn As ADODB.Connection
            
            'ADOのレコードセットの宣言を行う
            Dim rs As ADODB.Recordset
            
                '現在のACCESSのテーブルに接続する
                Set cn = CurrentProject.Connection
                
                'レコードセットのインスタンスをNewキーワードで生成する
                Set rs = New ADODB.Recordset
                    
                    '取り込みをおこなう[orderCapture]テーブルを開く
                    rs.Open "orderCapture", cn, adOpenKeyset, adLockOptimistic
                            
                            '※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
                            '取り込むテーブル[orderCapture]に今回取り込むエクセルデータが
                            'あるかを照合する
                            '[コンボBOXの発注者ID]+[受注番号]+[No]を結合した管理番号が
                            'テーブルに存在すれば、取り込み済みと判断する
                            '変数を増やしたくないので配列変数で対応する
                            
                            'unionFormatNo(0)はフォーマットして取り込む文字列を生成する
                            '[コンボBOXの発注者ID]+[受注番号]+[No]を結合した管理番号
                            '例:[AA-1111-0001]
                            Dim unionFormatNo(2) As String
                                
                            'ForNextステートメントのカウンター変数
                            '[i]はエクセルのファイルに登録してある件数をカウントする変数
                            Dim i As Long
                                
                            '[j]はエクセルファイルを実際に登録した件数をカウント
                            'すでにあるデータは登録させないアルゴリズムを組んでいるので
                            '実際の件数をjの変数で取得させる
                            Dim j As Integer
                            '初期化しておく
                                j = 0
    
  • 21
    PPP 2025/07/14 (月) 22:22:11 修正 50473@7267b >> 9

    (4-2)実際に処理する部分となります

    '※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※※
                          '1行ずつデータを読み込む
                          '読み込みする行は12行目から固定なので
                          'カウンター変数[i]は12から始まり、最後はエクセルデータを
                          '入力している最終行まで繰り返す
                          For i = 12 To myLastRow
                                                        
                              
                            '[コンボBOXの発注者ID]+[受注番号]+[No]を結合した管理番号を生成する
                            '例:[AA-1111-0001]
                            'この管理番号がACCESSのテーブルに登録された主キーとしての役目を持たせ
                            '重複して登録させない唯一の識別番号とさせる
                            unionFormatNo(0) = Me.cmb01.Column(1) & "-" & myOrderNo & "-" & Format(myXlWorksheet.Cells(i, 1).Value, "0000")
                              
                            '取り込み済みかを判定する
                            unionFormatNo(1) = Nz(DLookup("unionFormatNo", "orderCapture", "unionFormatNo ='" & unionFormatNo(0) & "'"), "Unregistered")
                              
                            'unionFormatNo(1)の値が"Unregistered"の時は登録する
                            '"Unregistered"でないときは、フォーマット形成した文字列が戻る為
                            'すでに登録済みとみなし、登録させない
                            If unionFormatNo(1) = "Unregistered" Then
                              
                                  'セルA番地のNoがゼロの時は入力データなしのため
                                  '取り込みしない。 ゼロより大きい値の時のみ取り込み開始
                                  If myXlWorksheet.Cells(i, 1).Value <> 0 Then
                                        
                                      'ADO経由でエクセルデータの登録を開始する
                                      rs.AddNew
                                    
                                          'エクセル番地の指定方法はCellsで指定する
                                          'Cells(行インデックス, 列インデックス)
                                 
                                           cells_No = myXlWorksheet.Cells(i, 1).Value
                                          
                                           'セル番地[A11]の[No]の値を登録するテーブル
                                           rs!noX = myXlWorksheet.Cells(i, 1).Value
    
                                           'セル番地[B11]の[品番]の値を登録するテーブル
                                           rs!partNumber = myXlWorksheet.Cells(i, 2).Value
                
                                           'セル番地[C11]の[品名]の値を登録するテーブル
                                           rs!productName = myXlWorksheet.Cells(i, 3).Value
        
                                           'セル番地[D11]の[数量]の値を登録するテーブル
                                            rs!quantity = myXlWorksheet.Cells(i, 4).Value
                
                                            'セル番地[E11]の[単価]の値を登録するテーブル
                                            rs!UnitPrice = myXlWorksheet.Cells(i, 5).Value
                
                                            'セル番地[F11]の[金額]の値を登録するテーブル
                                            rs!Totalamount = myXlWorksheet.Cells(i, 6).Value:
                
                                            'セル番地[G11]の[納期]の値を登録するテーブル
                                            rs!dayOfDelivery = myXlWorksheet.Cells(i, 7).Value
                
                                            'セル番地[H11]の[発注者備考]の値を登録するテーブル
                                            rs!remarks = myXlWorksheet.Cells(i, 8).Value
                    
                                            '[コンボBOXの発注者ID]+[受注番号]+[No]を結合した管理番号
                                            '例:[AA-1111-0001]
                                            rs!unionFormatNo = Me.cmb01.Column(1) & "-" & myOrderNo & "-" & Format(cells_No, "0000")
    
                                          rs.Update
                                             
                                          '登録件を更新していく
                                          j = j + 1
                                    End If
                            End If
    
                          Next i
      
    
  • 22
    PPP 2025/07/14 (月) 22:23:46 修正 50473@7267b >> 9

    (4-3)メモリーの解放をおこなう処理となります
    これでソースコードは終了となります。

               rs.Close: Set rs = Nothing
                cn.Close: Set cn = Nothing
        
                'Excelファイルを閉じる
                myXlWorkbook.Close
        
                'Excelアプリケーションを終了する
                myXlApp.Quit
    
                Set myXlWorksheet = Nothing
                Set myXlWorkbook = Nothing
                Set myXlApp = Nothing
                
                MsgBox ("登録件数は" & j & "件です")
                
                
                '取り込み成功のため共通変数はゼロを代入する
                judgement = 0
    
    End Sub
    

    アクセスのテーブルに取り込んだサンプルデータ

    画像1

    画像1

    画像1

    画像1

    画像1

  • 23
    PPP 2025/07/14 (月) 22:48:33 修正 50473@7267b >> 9

    かなり長いコードとなりますが、おおむねこれで質問者さんが質問に書かれていた
    エクセルの発注書に登録されているセル番地からデータを取得して転記することができます。

    処理を実現するためには、ポイントとして
    「Microsoft Excel XX.X Object Library」を
    参照設定にて使用できるように設定をおこなう。

    これは、エクセルファイルをアクセス側から読み書きできように
    するための処理です。このツールを設定することを知らないと
    アクセスからエクセルを自在に扱えないので、ここでつまずきます。

    そして次のポイントとして、アクセスのVBAだけでは実現できない処理を
    参照設定にて「microsoft ActivX Data object 6.1 Library」を使用
    出来るようにしてADOを使えるようにすることです。これにより
    アクセス以外のSQLServerやオラクルなどのデータベースなどと
    接続することができます。 

    これによりADOにおけるテーブルの更新処理なども柔軟におこなえるようになります。
    なによりVBAのコード内でADOの機能を利用してVBAだけでは不可能な処理を可能とします。

    外部参照設定をおこなうことにより、他のソフトなどの機能をアクセス内に
    取り込めます。 

    大まかにまとめると
    (1)「Microsoft Excel XX.X Object Library」
    (2)「microsoft ActivX Data object 6.1 Library」
    参照設定にて(1)(2)の機能を取り込むことにより今回の
    質問内容の処理を実行することが可能となるのです。

    追記ですが(3)のソースコードに
    取込み後にエクセルファイル名に「取り込み済」の文字を付加した
    構文も載せています。
    Nameステートメントでファイル名を書き換えております。

    Name oldpathname As newpathname
    
  • 26
    PPP 2025/07/15 (火) 06:47:59 修正 50473@7267b >> 9

    (4-2)に記載している[Private Sub callExceltable()]のコールプロシージャのままでは
    取込み用のエクセル以外を選択したときの判定処理がないため、データの整合性が保てません。
    なので 以下の判定用のプロシージャを追記します。

    For i = 12 To myLastRow '取込みファイルかを判定する
    

    の行にある12の部分を11に変えます。 
    エクセルの11行目の項目を判定するためです。

                            For i = 11 To myLastRow
                              
    '                          '11行目の項目が取り込みのエクセルファイルの形式かを判定する
    '                          '取り込みするエクセルファイルであるか判定するプロシージャー
                              If i = 11 Then
    '
    '                            '11行目が以下の並びの項目があるかを判定する
    '                            '項目名と並び順が違うと取り込みエクセルファイルでないと
    '                            '判断し、以降の処理は行わない
    '                            '+---+----+----+----+----+----+----+----------+
    '                            '|A列|B列 |C列  |D列 |E列 |F列 |G列 | H列      |
    '                            '+---+----+----+----+----+----+----+----------+
    '                            '|No |品番|品名 |数量|単価|金額 |納期|発注者備考 |
    '                            '+---+----+----+----+----+----+----+----------+
    '
    '                             '判定を繰り返すカウンター変数
                                  Dim k As Integer
    
                                  '項目を代入する配列変数
                                  Dim myArrry(8) As String
                                 'ゼロオリジンのため、ゼロから配列変数は始まります
                                 '今回ゼロは使用しないのですが
                                     '分かりやすくするための明示しています
                                     myArrry(0) = ""
                                     myArrry(1) = "No": myArrry(2) = "品番": myArrry(3) = "品名"
                                     myArrry(4) = "数量": myArrry(5) = "単価": myArrry(6) = "金額"
                                     myArrry(7) = "納期": myArrry(8) = "発注者備考"
    
                                      '8項目分繰り返す
                                      For k = 1 To 8
    
                                       If myXlWorksheet.Cells(11, k).Value <> myArrry(k) Then
    
                                        MsgBox ("取り込むエクセルファイルでありませんので処理を終了")
    
                                            '共通変数に取り込まないエクセルファイルとして
                                            '判別する値を代入する
                                                judgement = -1
    
                                                '以降の処理をさせない
                                                Exit Sub
    
    
                                       End If
    
                                     Next k
    
    
    
                              End If
    

    また [judgement]の変数は共通変数として使用するため
    投稿している(1)のプログラムの最終行に判定する変数を宣言します

        '取り込むエクセルファイルかを判定した値を保有
        '-1のときは取り込まないエクセルファイルと判定する
        Dim judgement As Integer
    

    そして投稿(3)のプロシージャに[judgement]変数に代入した
    判定値をもとに、エクセルのファイル名を変更するかの条件分岐を行います

    名前を変更するプログラムの場所を以下に書き換えます。

        '取り込むエクセルファイルのときは
                '名前を取り込み済みを接頭辞として付け加える
                If judgement = 0 Then
                
            
                    Dim pos As Long
                        '[\]の位置を検索
                        pos = InStr(1, path(1), "\")
            
                    'パスを取得する変数
                    'エクセルファイル名より前の
                    'パスの文字列を取得
                    Dim firstCharacter As String
                    
                    'ルートパスのみの文字列を取得する
                    firstCharacter = Left(path(1), pos)
                
                        '[\]が見つかった場合
                        If pos > 0 Then
                
                        Dim result As String
                            '[\]の次の文字から最後まで抽出
                            result = Mid(path(1), pos + 1)
                   
                    
                            'ファイル名を変える式
                            'Name oldpathname As newpathname
                            Name path(1) As firstCharacter & "取り込み済み" & result
                    End If
            
                End If
                
            
                    'FileDialogオブジェクトを解放する
                    Set myOrderFile = Nothing
     
    End Sub
    

    ソースコードが長いので変更箇所が分かりづらく恐縮ですが
    エクセルファイルが取込み対象かを判定する処理は盛り込んでいた方が
    大勢の人が取込み処理する場合には有用であるといえます。

    また取込みフォルダを固定化して、取込みたいエクセルファイルを
    指定したフォルダに入れておき、取込み後、取込み済みフォルダへ
    移動する方法もあります。 この方法であれば、ファイルを1個毎に
    選ばず一括処理できるので業務は楽になります。 
    FileSystemObjectを活用してフォルダ内のファイルを開いて
    取込み処理を行うソースコードを記述して運用しております。

    余談ですがEOS受信と呼ばれる方法であれば、取込みするファイルにはヘッダーとフッターとよばれる
    取込み判定する行があり、データを取り込む場合はヘッダーとフッターを読み込み
    取込みデータかを判定してから織り込み開始を行います。

  • 27

    処理内容が長いのキャプチャ画面を添付します。
    コードが長いので、2つの画面となります。 一部重複しております。
    画像1
    画像1