AccessVBA【SQL】Like演算子であいまい検索してレコード抽出

Sub set_○△□品番inSTOCK()

'ストックにある品番で、○△□に含まれる品番を抽出

'→ T_○△□品番 作成

Call clear_table("T_○△□品番")

Dim strSQL As String, str As String

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rsS As ADODB.Recordset

Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset
Set rsS = New ADODB.Recordset

strSQL = ""
strSQL = strSQL & " SELECT"
strSQL = strSQL & " tb1.品番 AS 品番"
strSQL = strSQL & " ,tb2.○△□ AS ○△□"
strSQL = strSQL & " FROM"
strSQL = strSQL & " M_○△□ AS tb1"
strSQL = strSQL & " INNER JOIN"
strSQL = strSQL & " T_○△□ AS tb2"
strSQL = strSQL & " ON"
strSQL = strSQL & " tb1.○△□ LIKE ('%'+ tb2.○△□ + '%') "
strSQL = strSQL & " ;"

rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic

strSQL = ""
strSQL = strSQL & " SELECT *"
strSQL = strSQL & " FROM T_○△□品番"
strSQL = strSQL & " ;"

rsS.Open strSQL, cn, adOpenKeyset, adLockOptimistic

If rs.RecordCount > 0 Then

    Do Until rs.EOF
        rsS.AddNew

        rsS!品番 = Nz(rs!品番, "")
        rsS!○△□ = Nz(rs!○△□, "")

        rsS.Update
        rs.MoveNext

    Loop

End If

rs.Close: rsS.Close

cn.Close: Set cn = Nothing
Set rs = Nothing
Set rsS = Nothing

End Sub

SQL 片方のTableのみにある行を抽出(LEFT JOIN)

strSQL = ""
strSQL = strSQL & " SELECT"
strSQL = strSQL & " tb1.商品ID AS 商品ID"
strSQL = strSQL & " ,tb1.商品管理番号 AS 商品管理番号"
strSQL = strSQL & " ,tb1.コントロール AS コントロール"
strSQL = strSQL & " ,tb1.公開ステータス AS 公開ステータス"
strSQL = strSQL & " ,tb1.単価 AS 単価"
strSQL = strSQL & " ,tb1.[参考価格/通常出品価格] AS [参考価格/通常出品価格]"
strSQL = strSQL & " ,tb1.参考価格 AS 参考価格"
strSQL = strSQL & " FROM"
strSQL = strSQL & " T_価格変更_BUYMA出品中_インポート AS tb1"
strSQL = strSQL & " LEFT OUTER JOIN"
strSQL = strSQL & " T_価格変更_タイムセール中_インポート AS tb2"
strSQL = strSQL & " ON"
strSQL = strSQL & " tb1.商品ID = tb2.商品ID"
strSQL = strSQL & " WHERE"
strSQL = strSQL & " tb2.商品ID is null"
strSQL = strSQL & " ;"

rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic

【Access VBA】【SQL】3つ(複数)のテーブルを結合してデータを抽出する

SQL 「LEFT JOIN」を使って、3つ以上の表を結合させる方法

AccessVBA で普通に join を使うと、2つまでしか結合できません。
が、下のように結合した表を括弧で囲んでやり、それを1つの表としてやると、
3つ以上の表を結合できます。

※テーブル名:TA,TB,TC
※フィールド名:b,c,id
※「TAテーブル」の全レコードに、
「TAテーブルのbフィールド」と「TBテーブルのidフィールド」が一致する「TBテーブル」のレコード、
「TAテーブルのcフィールド」と「TCテーブルのidフィールド」が一致する「TCテーブル」のレコードを
結合させる
SELECT TA.*,TB.*,TC.* FROM ( TA LEFT JOIN TB ON ( TA.b = TB.id ) ) LEFT JOIN TC ON ( TA.c = TC.id ) ;

また、中学生?のころに習った、電池のつなぎ方を思い出して、イメージしてみてください。
並列つなぎと、直列つなぎでは結果が違いますよ。それぞれのつなぎ方で「LEFT JOIN」 でテーブルを3つ結合できます。

★並列
A–>B
└–>C

★直列
A–>B–>C

どちらも可能。

【並列の例】

※テーブル名:A,B,C
※フィールド名:BID,CID
※「Aテーブル」の全レコードに、
「AテーブルのBIDフィールド」と「BテーブルのBIDフィールド」が一致する「Bテーブル」のレコード、
「AテーブルのCIDフィールド」と「CテーブルのCIDフィールド」が一致する「Cテーブル」のレコードを
結合させる
SELECT ・・・
FROM (A LEFT JOIN B ON A.BID = B.BID) LEFT JOIN C AS C ON A.CID = C.CID;

【直列の例】

※テーブル名:A,B,C
※フィールド名:BID,CID
※「Aテーブル」の全レコードに、
「AテーブルのBIDフィールド」と「BテーブルのBIDフィールド」が一致する「Bテーブル」のレコード、さらに
「BテーブルのCIDフィールド」と「CテーブルのCIDフィールド」が一致する「Cテーブル」のレコードを
結合させる
SELECT ・・・
FROM (A LEFT JOIN B ON A.BID = B.BID) LEFT JOIN C AS C ON B.CID = C.CID;

getElementByID(“id”)

getElementByID(“id”)・・・要素のIDを指定して単一の要素を取得
getElementsByName(“name”)・・・要素のNameを指定して単一の要素を取得
getElementsByTagName(“タグ名”)・・・要素のタグ名を指定して複数要素を取得
getElementsByTagName(“タグ名”)(n)・・・要素のタグ名を指定して複数要素の中からn番目の要素を取得
getElementsByClassName(“クラス名”)・・・要素のクラス名を指定して複数要素を取得
getElementsByClassName(“クラス名”)(n)・・・要素のクラス名を指定して複数要素の中からn番目の要素を取得
querySelector(“CSSセレクタ”)・・・CSSセレクタで要素を指定して複数要素の中から1番目の要素を取得
querySelectorAll(“CSSセレクタ”)・・・CSSセレクタで要素を指定して複数要素を取得
    Dim search_result_list
    Set search_result_list = oIE.Document.querySelectorAll(“.srg .rc”)
Private Sub cmd調査_Click()

    Dim r As Long
    Dim lastRow As Long, lng検索No As Long, lngページ数 As Long
    Dim str検索キー As String

    With Worksheets(sheetName2)
        
        For r = 1 To 5
        
            If .Range("C" & r + 4).Value = "" Then
                Exit Sub
            End If
        
            lng検索No = r
            str検索キー = .Range("B" & r + 4).Value & " " & Replace(.Range("C" & r + 4).Value, "-", " ")
            lngページ数 = 2
    
            'Yahoo!ショッピング検索
            Call set_Yahoo(lng検索No, str検索キー, lngページ数)

            '安値順にソート
            Call sort_Yahoo(lng検索No)

            'Yahoo!ショッピング表示
            Call set_Yahoo結果2(lng検索No, lngページ数)

            '楽天検索
            Call set_Rakuten2(lng検索No, str検索キー, lngページ数)
            
            '安値順にソート
            Call sort_Rakuten(lng検索No)

            '楽天表示
            Call set_Rakuten結果2(lng検索No, lngページ数)
            
        Next
        
    End With
    
    MsgBox "完了"

End Sub

Private Sub CommandButton2_Click()

'    Worksheets(sheetName2).Range("B5:C100").ClearContents
    Worksheets(sheetName2).Range("E5:AN100").ClearContents


End Sub
Sub set_Yahoo(lng検索No As Long, str検索キー As String, lngページ数 As Long)

'######################################################################
'
'           Yahoo!ショッピング内検索
'
'######################################################################

        Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
        Dim URL_search As String, strP As String, strV As String
        Dim txtInput As HTMLInputTextElement
        
        t = 0
        
        'ブラウザのオープン
        Dim objIE As InternetExplorer
        
        Set objIE = New InternetExplorer
        objIE.Visible = True
        
        'IEで開く
        objIE.Navigate searchURL_Y
        Call IEWait2(objIE)                          '自作関数: IE待機用
        Call WaitFor2(2)                             '自作関数: WaitFor2(t):t秒待機
    
       '検索情報の自動入力
        '検索BOX
        Set txtInput = objIE.document.getElementById("ss_yschsp")
        txtInput.Value = str検索キー
        
        '送信ボタン押下
        Set button = objIE.document.getElementById("ss_srch_btn")
        button.Click
    
        
        Call WaitFor2(2)
        
        '表示ボタンの切り替え(列表示)
'        Set button = objIE.document.querySelector(".Icon--list")
'        button.Click
    
        'サーチ結果のURL取得
        URL_search0 = objIE.document.url
        
        Application.ScreenUpdating = False

        nn = 2 '各シートの2行目から書き出す
        
        For k = 1 To lngページ数     'lngページ数まで検索する
        
            'URLの設定
            If k > 1 Then
                         
                URL_search = URL_search0 & "&b=" & 30 * k - 29
                
            Else
            
                URL_search = URL_search0

            End If
        
            objIE.Navigate URL_search
        
            Call IEWait2(objIE)
            Call WaitFor2(2)
            
            'search_result に検索結果部分をページごとにリストとして格納
            Dim search_result_list
            
            Set search_result_list = objIE.document.querySelectorAll(".LoopList__item")
            
            'search_result の個数分繰り返し処理
            With Worksheets("Y" & lng検索No)
                
                If search_result_list.Length = 0 Then Exit For
            
                For i = 0 To search_result_list.Length - 1
                    If InStr(search_result_list.Item(i).querySelector(".WeRPqEQO_DMj").innerText, "中古") = 0 Then
    
                        .Cells(nn, 1).Value = k
                        .Cells(nn, 2).Value = i + 1
'                        .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".WeRPqEQO_DMj").innerText  'タイトル
                        .Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href   'URL
                        .Cells(nn, 4).Value = search_result_list.Item(i).querySelector("._2RweXo29absZ").innerText  '店名
                        strV = search_result_list.Item(i).querySelector("._3Z3ly613XmPi").innerText   '価格
                        strP = search_result_list.Item(i).querySelector("._2UkNjGl36tm2").innerText   'ポイント
            
                        strV = Replace(strV, ",", "")
                        strV = Replace(strV, "円", "")
                        .Cells(nn, 5).Value = Val(strV)
                        .Cells(nn, 6).Value = Mid(strP, InStr(strP, "(") + 1, InStr(strP, "ポ") - InStr(strP, "(") - 1)

                        t = t + 1
                            
                    End If
            
                    nn = nn + 1
                     
                Next

                
            End With
            
            If t = 0 Then
                Worksheets(sheetName2).Range("E" & r).Value = "見つかりませんでした。"
            End If
        Next

            'IEクローズ
            objIE.Quit
            Set objIE = Nothing
        
        Application.ScreenUpdating = True

End Sub

Sub sort_Yahoo(lng検索No As Long)

'######################################################################
'
'           Yahoo!ショッピング内検索結果を安値でソート
'
'######################################################################
    Dim lastRow As Long

    With Worksheets("Y" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
    
        Call .Range("A2:F" & lastRow).Sort( _
                    Key1:=.Range("E1"), _
                    Order1:=xlAscending)
    
    
    End With
    
End Sub

Sub set_Rakuten(lng検索No As Long, str検索キー As String, lngページ数 As Long)

'######################################################################
'
'                 楽天内検索
'
'######################################################################

        Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
        Dim URL_search As String, strP As String, strV As String
        
        t = 0
        
        'ブラウザのオープン
        Dim objIE As InternetExplorer
        
        Set objIE = New InternetExplorer
        objIE.Visible = True
        
        'IEで開く
        objIE.Navigate searchURL_R
        Call IEWait2(objIE)                          '自作関数: IE待機用
        Call WaitFor2(2)                             '自作関数: WaitFor2(t):t秒待機

       '検索情報の自動入力
       '検索BOX
        Set txtInput = objIE.document.getElementById("sitem")
        txtInput.Value = str検索キー
        
        '送信ボタン押下
        Set button = objIE.document.getElementById("searchBtn")
        button.Click
        
        Call WaitFor2(2)
    
        'サーチ結果のURL取得
        URL_search = objIE.document.url
        
        Application.ScreenUpdating = False
        
        nn = 2 '各シートの2行目から書き出す
        
        For k = 1 To lngページ数     'lngページ数まで検索する
            'URLの設定
            If k > 1 Then
                URL_search2 = URL_search & "?p=" & k
            Else
                URL_search2 = URL_search

            End If
            
            On Error Resume Next

            Set objIE = New InternetExplorer
            objIE.Visible = True
            
            objIE.Navigate URL_search2
            

            Call IEWait2(objIE)
            Call WaitFor2(2)
            
            
            'search_result に検索結果部分をページごとにリストとして格納
            Dim search_result_list
            Set search_result_list = objIE.document.querySelectorAll(".searchresultitem")
            
            'search_result の個数分繰り返し処理
            With Worksheets("R" & lng検索No)
            
                If search_result_list.Length = 0 Then Exit For
            
                    For i = 0 To search_result_list.Length - 1
                        If InStr(search_result_list.Item(i).querySelector("h2").innerText, "中古") = 0 Then
                            
                            .Cells(nn, 1).Value = k
                            .Cells(nn, 2).Value = i + 1
                            .Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href   'URL
                            .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".merchant").innerText  '店名
                            strV = search_result_list.Item(i).querySelector(".important").innerText  '価格
                            strP = search_result_list.Item(i).querySelector(".points").innerText  'ポイント
                            
                            strV = Replace(strV, ",", "")
                            strV = Replace(strV, "円", "")
                            .Cells(nn, 5).Value = Val(strV)
                            .Cells(nn, 6).Value = Left(strP, InStr(strP, "ポ") - 1)
                            
                            t = t + 1
                            
                         End If
                         
                         nn = nn + 1
                    Next
                    
            End With
             
        Next

            'IEクローズ
            objIE.Quit
            Set objIE = Nothing
        
        Application.ScreenUpdating = True

'MsgBox "完了"



End Sub

Sub set_Rakuten2(lng検索No As Long, str検索キー As String, lngページ数 As Long)

'######################################################################
'
'                 楽天内検索
'
'######################################################################

        Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
        Dim URL_search As String, strP As String, strV As String
        Dim txtInput As HTMLInputTextElement
        Dim button As Object
    
        
        t = 0
        
        'ブラウザのオープン
        Dim objIE As InternetExplorer
        
        Set objIE = New InternetExplorer
        objIE.Visible = True
        
        'IEで開く
        objIE.Navigate searchURL_R
        Call IEWait2(objIE)                          '自作関数: IE待機用
        Call WaitFor2(2)                             '自作関数: WaitFor2(t):t秒待機

       '検索情報の自動入力
       '検索BOX
        Set txtInput = objIE.document.getElementById("common-header-search-input")
        txtInput.Value = str検索キー
        
        '送信ボタン押下
        Set button = objIE.document.getElementsByClassName("button--15weO button--uGWy7 undefined")(0)
        button.Click
        
        Call WaitFor2(2)
    
        'サーチ結果のURL取得
        URL_search = objIE.document.url
        
        Application.ScreenUpdating = False
        
        nn = 2 '各シートの2行目から書き出す
        
        For k = 1 To lngページ数     'lngページ数まで検索する
            'URLの設定
            If k > 1 Then
                URL_search2 = URL_search & "?p=" & k
            Else
                URL_search2 = URL_search

            End If
            
            On Error Resume Next

            Set objIE = New InternetExplorer
            objIE.Visible = True
            
            objIE.Navigate URL_search2
            

            Call IEWait2(objIE)
            Call WaitFor2(2)
            
            
            'search_result に検索結果部分をページごとにリストとして格納
            Dim search_result_list
            Set search_result_list = objIE.document.querySelectorAll(".searchresultitem")
            
            'search_result の個数分繰り返し処理
            With Worksheets("R" & lng検索No)
            
                If search_result_list.Length = 0 Then Exit For
            
                    For i = 0 To search_result_list.Length - 1
                        If InStr(search_result_list.Item(i).querySelector("h2").innerText, "中古") = 0 Then
                            
                            .Cells(nn, 1).Value = k
                            .Cells(nn, 2).Value = i + 1
                            .Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href   'URL
                            .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".merchant").innerText  '店名
                            strV = search_result_list.Item(i).querySelector(".important").innerText  '価格
                            strP = search_result_list.Item(i).querySelector(".points").innerText  'ポイント
                            
                            strV = Replace(strV, ",", "")
                            strV = Replace(strV, "円", "")
                            .Cells(nn, 5).Value = Val(strV)
                            .Cells(nn, 6).Value = Left(strP, InStr(strP, "ポ") - 1)
                            
                            t = t + 1
                            
                         End If
                         
                         nn = nn + 1
                    Next
                    
            End With
             
        Next

            'IEクローズ
            objIE.Quit
            Set objIE = Nothing
        
        Application.ScreenUpdating = True

'MsgBox "完了"



End Sub

Sub sort_Rakuten(lng検索No As Long)

'######################################################################
'
'           Rakuten内検索結果を安値でソート
'
'######################################################################
    Dim lastRow As Long

    With Worksheets("R" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
    
        Call .Range("A2:F" & lastRow).Sort( _
                    Key1:=.Range("E1"), _
                    Order1:=xlAscending)
    
    
    End With
    
End Sub

'IE待機用関数
Public Sub IEWait2(ByRef objIE As Object)
    Do While objIE.Busy Or objIE.readyState <> 4
        DoEvents
    Loop
End Sub

't[sec]待機させる関数
Public Sub WaitFor2(ByVal second As Integer)
    Dim futuretime As Date
    futuretime = DateAdd("s", second, Now)
    While Now < futuretime
        DoEvents
    Wend
End Sub


Sub set_Yahoo結果(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String
    
    '占有率表示
    With Worksheets("Y" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No + 1
        
        If lastRow > 1 Then
        
            rowNo = .Range("D2:D" & lastRow).Find(str店名, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(M列)、価格(N列)、商品URL(O列)
            Worksheets(sheetName).Range("M" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName).Range("N" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName).Range("O" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName).Range("O" & lng行番号), _
                                                           Address:=strURL)
        
            For i = 2 To 6
               'Q列(価格)、R列(店舗名)、S列(ポイント)
                Worksheets(sheetName).Range("Q" & lng行番号).Value = .Range("E" & i).Value
                Worksheets(sheetName).Range("R" & lng行番号).Value = .Range("D" & i).Value
                Worksheets(sheetName).Range("S" & lng行番号).Value = .Range("F" & i).Value
            
                lng行番号 = lng行番号 + 1
                
            Next i
            
         End If

    End With
    
    
End Sub

Sub set_Yahoo結果2(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String, rngA As Range
    
    '占有率表示
    With Worksheets("Y" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No + 4
        
        If lastRow > 1 Then
        
            On Error GoTo myError
            
            Set rngA = .Range("D2:D" & lastRow)
        
            rowNo = rngA.Find(str店名, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(M列)、価格(N列)、商品URL(O列)
            Worksheets(sheetName2).Range("W" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName2).Range("X" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName2).Range("Y" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName2).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName2).Range("Y" & lng行番号), _
                                                           Address:=strURL)
        
            For i = 0 To 4
               'Q列(価格)、R列(店舗名)、S列(ポイント)
                Worksheets(sheetName2).Cells(lng行番号, 26 + i * 3).Value = .Range("E" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 27 + i * 3).Value = .Range("D" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 28 + i * 3).Value = .Range("F" & i + 2).Value
                
            Next i
            
         End If

    End With
    
    Exit Sub
    
myError:
    MsgBox "ヤフショの検索結果では、モダンブルーの商品は見つかりません。検索対象の品番を見直すか、検索ページ数を増やしてください。"       '表示されます
    
    
End Sub

Sub set_Rakuten結果(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String
    
    '占有率表示
    With Worksheets("R" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No * 5 + 1
        
        If lastRow > 1 Then
        
            rowNo = .Range("D2:D" & lastRow).Find(str店名2, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(F列)、価格(G列)、商品URL(H列)
            Worksheets(sheetName).Range("F" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName).Range("G" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName).Range("H" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName).Range("H" & lng行番号), _
                                                           Address:=strURL)
        
            For i = 2 To 6
               'J列(価格)、K列(店舗名)、L列(ポイント)
                Worksheets(sheetName).Range("J" & lng行番号).Value = .Range("E" & i).Value
                Worksheets(sheetName).Range("K" & lng行番号).Value = .Range("D" & i).Value
                Worksheets(sheetName).Range("L" & lng行番号).Value = .Range("F" & i).Value
            
                lng行番号 = lng行番号 + 1
                
            Next i
            
         End If

    End With
    
End Sub


Sub set_Rakuten結果2(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String
    
    '占有率表示
    With Worksheets("R" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No + 4
        
        If lastRow > 1 Then
        
            rowNo = .Range("D2:D" & lastRow).Find(str店名2, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(F列)、価格(G列)、商品URL(H列)
            Worksheets(sheetName2).Range("E" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName2).Range("F" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName2).Range("G" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName2).Range("G" & lng行番号), _
                                                           Address:=strURL)
        

            
            For i = 0 To 4
               '(価格)、(店舗名)、(ポイント)
                Worksheets(sheetName2).Cells(lng行番号, 8 + i * 3).Value = .Range("E" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 9 + i * 3).Value = .Range("D" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 10 + i * 3).Value = .Range("F" & i + 2).Value
                
            Next i
            
         End If

    End With
    
End Sub


Public Const searchURL_R = "https://www.rakuten.co.jp/"

Public Const searchURL_Y = "https://shopping.yahoo.co.jp/"

Public Const sheetName = "最安値調査"

Public Const sheetName2 = "改善案"

Public Const str店名 = "モダンブルーYahoo!店"

Public Const str店名2 = " モダンブルー楽天市場店"

AccessVBA CSVファイルの1行目に不要な文字列がある為、2行目からインポート

※1行目を削除すると、2行目にある見出しの行がそのままフィールド名として使えるようにしたい。

方法はいくつかあるけど、FileSystemObject (MSDN) を使う例だと、

    Dim fso, fromFile, toFile
    Set fso = CreateObject(“Scripting.FileSystemObject”)
    Set fromFile = fso.OpenTextFile(“C:\hoge\text1.csv”, ForReading)
    Set toFile = fso.OpenTextFile(“C:\hoge\text2.csv”, ForWriting, True)
    fromFile.SkipLine ’ ここで1行進める
    toFile.Write fromFile.ReadAll
    fromFile.Close
    toFile.Close

FYI

ReadAll メソッド (MSDN) 

フォームデータソースの参照エラー(型が一致しません。フォームが見つかりません。etc.)

【 解決策 】

①親フォーム名から指定する(サブフォームから指定してもダメ)
②親フォームを開いた状態で、レコードソースの変更コードを当てる

指定した式で、閉じているかまたは存在しないオブジェクトを参照しています
ということなので
オブジェクト=フォームが見つからないよ?と言ってます。
・フォームを開いていないか
・フォーム名が間違っているか
・フォームの指定方法が間違っているか↓
http://hatenachips.blog34.fc2.com/blog-entry-347.html

<フォームの指定方法>
Forms!ナビゲーションフォーム名!サブフォームコントロール名.Form.コントロール名

Forms!Aフォーム!NavigationSubform.Form!Btn_Input.Enabled = False

[Forms]![ナビゲーションフォーム名]![NavigationSubform].[Form]![ComboB]

<今回の間違い>
Forms!fm_本店カテゴリ作成明細フォーム.RecordSelectors = “X_M商品カテゴリ7″

<今回の正解>
Forms!fm_本店カテゴリ作成2!明細フォーム.Form.RecordSource = “X_M_商品カテゴリ7”

<フォームとコントロールの設定状況>
※親フォーム名:fm_本店カテゴリ作成2
※サブフォーム名(コントロール名):明細フォーム
 サブフォームの参照先フォーム:fm_本店カテゴリ作成_明細フォーム

Access 実行時エラー 3052 ”ファイルの共有ロック数が制限を超えています” ”解決方法

https://motagp.hatenablog.com/entry/2015/05/22/111246

Microsoftの技術情報
多数のトランザクション処理中にエラー メッセージ “ファイルの共有ロック数が制限を超えています” が表示される

トランザクションとかかけてないし、何??
資料見ると
「方法 1 : MaxLocksPerFile レジストリ キーを設定して、ファイルごとの最大ロック数を増やす」
おいおい、このアプリ導入している端末全部変えるの?無理あるよね。

「方法 2 : SetOption メソッドを使用して MaxLocksPerFile の値を一時的に変更する」
これこれ、試しました。
規定値が9500なので倍にしたけど駄目。
30000に変更したら、Windows2008R2+Access2007で動作。
でもWindows7+Access2007では同じエラー、さらに40000へアップ。
やっと動きました!


VBAに追加したコードはこれです。
  DBEngine.SetOption dbMaxLocksPerFile, 40000

Accessでは勝手にトランザクション処理が動いていて、初期値9500件を超えると、3052エラーが発生するそうです。
対処方法は、安易に最大値を増やすのではなく、定期的にコミットする事。 

変更したコードが下記です。(赤色追記)

Dim intTranCount AS integer
Set rsOut = dbCUR.OpenRecordset(“SELECT * FROM OXテーブル”)

intTranCount = 0
DBEngine.BeginTrans

Do While Not rsOut.EOF
 rsOut.Edit
 rsOut(21).Value = rsOut(10).Value
 rsOut.Update
 rsOut.MoveNext
 ’トランザクションMAX制御
 intTranCount = intTranCount + 1
 If intTranCount = 5000 Then
  DBEngine.CommitTrans
  DBEngine.BeginTrans
  intTranCount = 0
 End If

Loop
DBEngine.CommitTrans
rsOut.Close

AccessVBAでクエリを実行

Visual Basic EditorでSQLステートメントを記述する場合、基本構文はSQLビューと同じですが、ステートメントの記述方法が少し違います。SQLステートメントは、VBAでは文字列として扱われます。そのためSQLステートメントをダブルクォーテーションで囲む必要があります。抽出条件が文字列の場合は、条件値をシングルクォーテーションで囲みます。

アクションクエリをVBAで実行するには、RunSQLメソッドを使います。

《書式》

DoCmd.RunSQL “SQLステートメント”

《設定例》

複数行に分ける場合、行ごとにダブルクォーテーションで囲み、アンパサンド(&)と、行継続文字を入力します。
行の終わりの文字とアンパサンドの前後には半角スペースを入力する必要があります。
下記例は、「T顧客マスタ」テーブルの「都道府県」が“東京都”のレコードを表示するというものです。

“SELECT * FROM T顧客マスタ” & _
“WHERE 都道府県 = ‘東京都 ‘”

《設定例》※SQL練習1.mdb の“F都道府県抽出”

次の例では、コンボボックス「都道府県」で指定した値で抽出し、リストボックスに
表示しています。
RowSourceプロパティを使うと、は連結していないデータをリストボックスに表示できます。

Private Sub 都道府県_AfterUpdate() Me!表示.RowSource = “SELECT * FROM T得意先マスタ ” & _
” WHERE 都道府県 = ‘” & Me!都道府県 & “‘” End Sub

アクションクエリの種類 

アクションクエリには4つの種類があります。

  1. 追加クエリ(INSERT INTO)
  2. 更新クエリ(UPDATE)
  3. 削除クエリ(DELETE)
  4. テーブル作成クエリ(SELECT INTO)

追加クエリ(レコードを登録する) 

《書式》

INSERT INTO 追加先テーブル名
SELECT フィールド名
FROM 追加元テーブル名
WHERE 条件式

フィールド名は、複数のフィールドを指定する場合はカンマで区切り、すべてのフィールドを指定する場合はアスタリスク(*)を入力します。
条件式は、「フィールド名 演算子 値」の形式で指定します。

《設定例》

次の例は、T商品マスタの備考フィールドが“限定品”のレコードを、「T限定品」テーブルに追加します。

DoCmd.RunSQL “INSERT INTO T限定品 SELECT * FROM T商品マスタ ” & _
“WHERE 備考 = ‘限定品'”

更新クエリ(レコードを更新する)

《書式》

UPDATE テーブル名
SET 更新する値
WHERE 条件式

《設定例》

‘T得意先マスタの「チェック」フィールドをすべてONにする
Dim SQL As String
SQL = “UPDATE T得意先マスタ ” & _
     ”SET チェック = On “
DoCmd.RunSQL SQL

削除クエリ(レコードを削除する)

削除クエリを使うと、指定条件を満たすレコードをテーブルから削除できます。

《書式》

DELETE FROM テーブル名
WHERE 条件式

《設定例》

次の例ではT得意先マスタの「顧客区分」フィールドの値が“D”のレコードを削除します。

Dim SQL As String

SQL = “DELETE FROM T得意先マスタ ” & _
     “WHERE 顧客区分 = ‘D’ “
DoCmd.RunSQL SQL

テーブル作成クエリ 

元のテーブルをコピーして新しいテーブルを作成します。

《書式》

SELECT フィールド名
INTO 新しいテーブル名
FROM 元のテーブル名
WHERE 条件式

《設定例》

「T得意先マスタ」テーブルで、都道府県が“埼玉県”のすべてのレコードをコピーして 「T顧客マスタ」テーブルを作成します。

Dim SQL As String
SQL = “SELECT * INTO T顧客マスタ ” & _
     “FROM T得意先マスタ ” & _
     “WHERE 都道府県 = ‘埼玉県'”
DoCmd.RunSQL SQL