VBA模块覆盖值

Question

在覆盖值方面存在问题。也就是说，当我输入多个值时，我的模块会在某个数据库中获取并验证这些值，它会覆盖从同一行的第一个值验证的已经导入的信息。

它实际上应该将信息存储在导入值的同一行中。小插图

No.  Entered Values    How it stores   / How it should be stored
1.   111               *333imported*     *111imported*
2.   222                                 *222imported*
3.   333                                 *333imported*

我的代码

Sub SearchGB()
Dim objIE As InternetExplorer
Dim ele As Object
Dim t As Date
Dim GrantNum As String
Dim i As Long
Dim j As Integer
Dim wsh As Worksheet
Dim Addme As Range
Dim rng As Range
Dim cell As Range
Set wsh = ThisWorkbook.Sheets("Great Britain")
Set Addme = wsh.Cells(Rows.Count, "A").End(xlUp)
Set objIE = New InternetExplorer
Set rng = wsh.Range("B4:B100")
For Each cell In rng.Cells
    If InStr(1, cell, "EP") > 0 Then
    GrantNum = cell
Const MAX_WAIT_SEC As Long = 10 '<==Adjust wait time
If InStr(1, GrantNum, "EP") = 0 Then
    MsgBox "Please enter correct form of Grant Number"
    Else
objIE.Visible = True
objIE.navigate "https://www.ipo.gov.uk/p-ipsum/Case/PublicationNumber/" & GrantNum
End If
While objIE.Busy Or objIE.readyState < 4: DoEvents: Wend
t = Timer
Do
    DoEvents
    On Error Resume Next
    Set ele = objIE.document.getElementById("externalcontent")
    If Timer - t > MAX_WAIT_SEC Then Exit Do
    On Error GoTo 0
Loop While ele Is Nothing
j = 0
With wsh
Set ele = objIE.document.getElementById("MainContent_BibliographyViewUserControl_BibliographyTable").getElementsByTagName("td")
For i = 0 To ele.Length - 1
        If Trim$(ele.Item(i).innerText) = "Applicant / Proprietor" Then
            Addme.Cells(j, 8).Value = ele.Item(i + 1).innerText
        End If
        If Trim$(ele.Item(i).innerText) = "Application Number" Then
            Addme.Cells(j, 3).Value = ele.Item(i + 1).innerText
        End If
        If Trim$(ele.Item(i).innerText) = "Publication Number" Then
            Addme.Cells(j, 5).Value = ele.Item(i + 1).innerText
        End If
        If Trim$(ele.Item(i).innerText) = "Status" Then
            Addme.Cells(j, 7).Value = ele.Item(i + 1).innerText
        End If
        If Trim$(ele.Item(i).innerText) = "Grant Date" Then
            Addme.Cells(j, 6).Value = ele.Item(i + 1).innerText
        End If
        If Trim$(ele.Item(i).innerText) = "Filing Date" Then
            Addme.Cells(j, 4).Value = ele.Item(i + 1).innerText
        End If
    Next i
    End With
    End If
Next cell
'objIE.Quit
End Sub

无论我在哪里写j = j + 1，它都不起作用。

Answer 1

将代码放在A列或将代码设置在那里，j=0必须在for Each单元格之外，并且只有在接受条件时才递增，在那里进行必要的调整。祝你好运

Sub SearchGB()
Dim objIE As InternetExplorer
Dim ele As Object
Dim t As Date
Dim GrantNum As String
Dim GrantNum2 As String
Dim i As Long
Dim j As Integer
Dim wsh As Worksheet
Dim Addme As range
Dim rng As range
Dim cell As range
Set wsh = ThisWorkbook.Sheets("Great Britain")
Set Addme = wsh.Cells(Rows.Count, "A").End(xlUp)
Set objIE = New InternetExplorer
Set rng = wsh.range("A1:A10")
j = 0
For Each cell In rng.Cells
    If InStr(1, cell, "EP") > 0 Then
    GrantNum = ThisWorkbook.Sheets("Great Britain").Cells(1, 1).Value 'cell
    ThisWorkbook.Sheets("Great Britain").Cells(1, 2).Value = Left(GrantNum, Len(GrantNum) - 2)
    GrantNum2 = ThisWorkbook.Sheets("Great Britain").Cells(1, 2).Value 'cell
Const MAX_WAIT_SEC As Long = 10 '<==Adjust wait time
If InStr(1, GrantNum, "EP") = 0 Then
        MsgBox "Please enter correct form of Grant Number"
        Else
    objIE.Visible = True
    objIE.navigate "https://www.ipo.gov.uk/p-ipsum/Case/PublicationNumber/" & GrantNum2
    End If
    
    While objIE.Busy Or objIE.readyState < 4: DoEvents: Wend
    t = Timer
    Do
        DoEvents
        On Error Resume Next
        Set ele = objIE.document.getElementById("externalcontent")
        If Timer - t > MAX_WAIT_SEC Then Exit Do
        On Error GoTo 0
    Loop While ele Is Nothing
    
    j = j + 1
    
    With wsh
        Set ele = objIE.document.getElementById("MainContent_BibliographyViewUserControl_BibliographyTable").getElementsByTagName("td")
        For i = 0 To ele.Length - 1
            If Trim$(ele.Item(i).innerText) = "Applicant / Proprietor" Then
                ThisWorkbook.Sheets("Great Britain").Cells(j + 1, "H").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Application Number" Then
               ThisWorkbook.Sheets("Great Britain").Cells(j + 1, "C").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Publication Number" Then
                ThisWorkbook.Sheets("Great Britain").Cells(j + 1, "E").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Status" Then
                ThisWorkbook.Sheets("Great Britain").Cells(j + 1, "G").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Grant Date" Then
                ThisWorkbook.Sheets("Great Britain").Cells(j + 1, "F").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Filing Date" Then
                ThisWorkbook.Sheets("Great Britain").Cells(j + 1, "D").Value = ele.Item(i + 1).innerText
            End If
        Next i
    End With
End If
Next cell
'objIE.Quit
End Sub

Answer 2

谢谢你的朋友，我做到了！：(通过一些你和我以前的代码的混合，我终于成功了！

Sub SearchGB()
Dim objIE As InternetExplorer
Dim ele As Object
Dim t As Date
Dim GrantNum As String
Dim i As Long
Dim j As Integer
Dim wsh As Worksheet
Dim Addme As Range
Dim rng As Range
Dim cell As Range
Set wsh = ThisWorkbook.Sheets("Great Britain")
Set Addme = wsh.Cells(Rows.Count, "A").End(xlUp)
Set objIE = New InternetExplorer
Set rng = wsh.Range("B2:B100")
j = 0
For Each cell In rng.Cells
    If InStr(1, cell, "EP") > 0 Then
    GrantNum = cell
Const MAX_WAIT_SEC As Long = 10 '<==Adjust wait time
If InStr(1, GrantNum, "EP") = 0 Then
    MsgBox "Please enter correct form of Grant Number"
    Else
objIE.Visible = True
objIE.navigate "https://www.ipo.gov.uk/p-ipsum/Case/PublicationNumber/" & GrantNum
End If
While objIE.Busy Or objIE.readyState < 4: DoEvents: Wend
t = Timer
Do
    DoEvents
    On Error Resume Next
    Set ele = objIE.document.getElementById("externalcontent")
    If Timer - t > MAX_WAIT_SEC Then Exit Do
    On Error GoTo 0
Loop While ele Is Nothing
j = j + 1
With wsh
Set ele = objIE.document.getElementById("MainContent_BibliographyViewUserControl_BibliographyTable").getElementsByTagName("td")
For i = 0 To ele.Length - 1
        If Trim$(ele.Item(i).innerText) = "Applicant / Proprietor" Then
                wsh.Cells(j + 1, "H").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Application Number" Then
               wsh.Cells(j + 1, "C").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Publication Number" Then
                wsh.Cells(j + 1, "E").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Status" Then
                wsh.Cells(j + 1, "G").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Grant Date" Then
                wsh.Cells(j + 1, "F").Value = ele.Item(i + 1).innerText
            ElseIf Trim$(ele.Item(i).innerText) = "Filing Date" Then
                wsh.Cells(j + 1, "D").Value = ele.Item(i + 1).innerText
            End If
    Next i
    End With
    End If
Next cell
objIE.Quit
End Sub