(VBA)ExcelデータをIEへ転記する際、想定の行とは異なる行が転記される

セルにあるボタンをクリックしたらそのボタンがある行がWebサイトへ転記されるというVBAを作りました。
6行目までは正常に動作するのですが、7行目以降から想定の行とは異なる行が転記されてしまいます。
例えば、7行目をクリックすると18行目が転記されてしまいます。
アドバイス頂けませんでしょうか？
宜しくお願い致します。

Excelシートは以下のようになっております。
![

VBA
1Option Explicit
2Sub btn()
3
4    '変数にワークシート「データ収集」を格納
5    Dim wsTotal As Worksheet
6    Set wsTotal = Worksheets("あて先")
7    
8    'タイトル行を取得する
9    Dim r As Integer
10    r = Worksheets("あて先").Range("B1").Row
11    
12    'ダイアログからブックを選び、パスを格納
13    Dim openPath As String
14    openPath = Application.GetOpenFilename("Microsoft Excelブック,*.csv?")
15    
16    '画面の描画を停止する
17    Application.ScreenUpdating = False
18    
19    'パスが「False」でなければ処理を行う
20    If openPath <> "False" Then
21    
22        '変数を用意し、ブックを開いて格納
23        Dim openBook As Workbook
24        Set openBook = Workbooks.Open(openPath)
25        
26        
27        '最終行を取得しておく
28        Dim LastRow As Integer
29        LastRow = openBook.Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row + 1
30        
31
32        '各項目をそれぞれ転記する
33        '※openBookの最初のワークシート(1)から
34        
35        Dim i As Integer
36        For i = 2 To LastRow
37        
38            r = r + 1
39            
40            wsTotal.Range("B" & r).Value = openBook.Worksheets(1).Range("AH" & i).Value
41            wsTotal.Range("C" & r).Value = openBook.Worksheets(1).Range("C" & i).Value
42            wsTotal.Range("D" & r).Value = openBook.Worksheets(1).Range("G" & i).Value
43            wsTotal.Range("E" & r).Value = openBook.Worksheets(1).Range("H" & i).Value
44            wsTotal.Range("F" & r).Value = openBook.Worksheets(1).Range("I" & i).Value
45            wsTotal.Range("G" & r).Value = openBook.Worksheets(1).Range("J" & i).Value
46            wsTotal.Range("H" & r).Value = openBook.Worksheets(1).Range("D" & i).Value
47            wsTotal.Range("I" & r).Value = openBook.Worksheets(1).Range("F" & i).Value
48            wsTotal.Range("N" & r).Value = openBook.Worksheets(1).Range("O" & i).Value
49        
50        Next
51
52
53        'openBookを閉じる
54        openBook.Close
55        
56        '画面の描画を再開する
57        Application.ScreenUpdating = True
58        
59        'あて先Sheetへ移る
60        Worksheets("あて先").Select
61
62        '処理が終わったことをMsgBoxで出力
63        MsgBox "ブックからデータを抽出しました。"
64
65    End If
66    
67        '半角文字を全角に変換
68        Dim MojiEX As Range
69        
70        '範囲を指定する
71        For Each MojiEX In Range("F2:I30")
72        
73            '半角文字⇒全角文字に変換
74            MojiEX.Value = StrConv(MojiEX, vbWide)
75            
76        Next MojiEX
77    
78
79End Sub
80
81Sub クリア()
82
83    Worksheets("あて先").Range("A2:N100").Value = ""
84    Worksheets("あて先").Range("A:A").Interior.ColorIndex = 0
85    Worksheets("あて先").Select
86    MsgBox "データを削除しました。"
87    Worksheets("マクロボタン").Select
88    
89End Sub
90
91Function tenki(ByVal a As Integer, ByVal d As Integer, ByVal e As Integer, ByVal f As Integer, ByVal g As Integer) As Integer
92
93    Dim colSh As Object
94    Dim win As Object
95    Dim objIE As Object
96    Set colSh = CreateObject("Shell.Application")
97    
98    '開いているすべてのウインドウに対して処理する
99    For Each win In colSh.Windows
100
101    On Error Resume Next 'Window取得エラー対策
102    '開いているファイルの種類がHTMLなら処理を実行する
103    If TypeName(win.document) <> "HTMLDocument" Then
104    Else
105    
106        '開いているサイトのURLが下記だったら
107        If win.LocationURL = "https://www.shopjapan.co.jp/shop/customer/entry" Then
108        'If win.document.Url = "https://www.shopjapan.co.jp/shop/customer/entry" Then
109
110            'このウインドウをobjIEとして指定する
111            Set objIE = win
112
113            objIE.document.getElementsByName("customerLastNameKana")(0).Value = Left(Range("D" & d).Value, 3)
114            objIE.document.getElementsByName("customerFirstNameKana")(0).Value = Right(Range("D" & d).Value, 4)
115            objIE.document.getElementsByName("address1")(0).Value = Mid(Range("E" & e).Value, 4)
116            objIE.document.getElementsByName("address2")(0).Value = Range("F" & f).Value
117            objIE.document.getElementsByName("address3")(0).Value = Range("G" & g).Value
118            
119            '都道府県コードをAddressへ代入
120            Dim Address As Object
121            Dim Addresses As Object
122            Set Addresses = objIE.document.getElementById("todofukenCd")
123
124            'リスト項目名で選択 E列にある都道府県名を選択
125            For Each Address In Addresses.getElementsByTagName("option")
126                If Address.innerText = Left(Range("E" & e).Value, 3) Then
127                    Address.Selected = True
128                End If
129            Next
130
131            '処理を中断してFor~Nextを終了する
132            Exit For
133            
134        End If
135        
136    End If
137    
138    On Error GoTo 0
139    
140    Next
141    
142    'ウインドウが見つからなければ
143    If objIE Is Nothing Then
144    
145        'メッセージを表示して
146         MsgBox "入力するページが見つかりません"
147    
148        '処理を終了する
149        Exit Function
150    
151    End If
152    
153    Range("A" & a).Interior.Color = RGB(255, 0, 0)
154End Function
155Sub 転記()
156
157    Dim a As Integer
158
159    a = Val(Mid(Application.Caller, 5)) + 1
160
161    Call tenki(a, a, a, a, a)
162    
163End Sub

meg_

2020/10/02 23:47

ワークシート上のボタンをクリックしたときに実行される関数はどれですか？

js_boy

2020/10/03 00:22 編集

下記コードになります。 ------------------------------------------------- Function tenki(ByVal a As Integer, ByVal d As Integer, ByVal e As Integer, ByVal f As Integer, ByVal g As Integer) As Integer Dim colSh As Object Dim win As Object Dim objIE As Object Set colSh = CreateObject("Shell.Application") '開いているすべてのウインドウに対して処理する For Each win In colSh.Windows On Error Resume Next 'Window取得エラー対策 '開いているファイルの種類がHTMLなら処理を実行する If TypeName(win.document) <> "HTMLDocument" Then Else '開いているサイトのURLが下記だったら If win.LocationURL = "https://www.shopjapan.co.jp/shop/customer/entry" Then 'If win.document.Url = "https://www.shopjapan.co.jp/shop/customer/entry" Then 'このウインドウをobjIEとして指定する Set objIE = win objIE.document.getElementsByName("customerLastNameKana")(0).Value = Left(Range("D" & d).Value, 3) objIE.document.getElementsByName("customerFirstNameKana")(0).Value = Right(Range("D" & d).Value, 4) objIE.document.getElementsByName("address1")(0).Value = Mid(Range("E" & e).Value, 4) objIE.document.getElementsByName("address2")(0).Value = Range("F" & f).Value objIE.document.getElementsByName("address3")(0).Value = Range("G" & g).Value '都道府県コードをAddressへ代入 Dim Address As Object Dim Addresses As Object Set Addresses = objIE.document.getElementById("todofukenCd") 'リスト項目名で選択 E列にある都道府県名を選択 For Each Address In Addresses.getElementsByTagName("option") If Address.innerText = Left(Range("E" & e).Value, 3) Then Address.Selected = True End If Next '処理を中断してFor~Nextを終了する Exit For End If End If On Error GoTo 0 Next 'ウインドウが見つからなければ If objIE Is Nothing Then 'メッセージを表示して MsgBox "入力するページが見つかりません" '処理を終了する Exit Function End If Range("A" & a).Interior.Color = RGB(255, 0, 0) End Function Sub 転記() Dim a As Integer a = Val(Mid(Application.Caller, 5)) + 1 Call tenki(a, a, a, a, a) End Sub

meg_

2020/10/03 00:55 編集

上記コメントには「Function tenki」と「Sub 転記」と2つあるんですが、ボタンに登録してあるのはどっちですか？「Sub 転記」ですよね？

js_boy

2020/10/03 01:02

説明不足ですみません。ボタンに登録してあるのはSub 転記の方です！

行動規範の内容に同意します

回答2件

考えられる原因としては、マクロ作成時に試行錯誤していて現在のボタン以外に多くのボタンを作成していて、おそらくボタン6～ボタン16を削除したのだと思います。

下記はボタン 3をクリックした例です。※表示はボタン 3ですが、ボタン名はButton 20です。

VBA
1Sub ボタン1_Click()
2
3    Dim a As Integer
4
5    a = Val(Split(Application.Caller)(1))
6
7    MsgBox a
8
9End Sub

質問者さんの場合は、ボタン名を修正するか新規にボタンを作成してマクロを登録すれば良いかと思います。

投稿2020/10/03 01:22

meg_

総合スコア10579

js_boy

2020/10/03 01:27

ご回答ありがとうございます。他のご回答者様からもご指摘があったんですが、ボタン名とボタンのキャプションを混同しておりました。またmeg_様のご指摘の通り、試行錯誤した結果、ボタンを作りまくっておりましたｗ以上を踏まえ、作り直したところ正常に動作致しました。この度はご回答いただきましてありがとうございました！！

行動規範の内容に同意します