Question

我创建了一个从网站（“希望此代码可以帮助很多观众”）中删除数据的宏，然后将其打印到工作表Feuil1中，代码完美无缺，但唯一的问题总是我填写表格有问题：'（

这意味着当我运行代码时，它会提取特定数据，但我不知道如何在其前面添加该数据，例如column D。

废弃网站代码：

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   Sub extt()

   Dim IE As Object, obj As Object
   Dim itm As IHTMLElement
   Dim htmlcurrentDoc As IHTMLElement
   Dim elemCollection As Object
   Dim c As Long, d As Long, i As Long, x As Long, f As Variant
   Dim tags As Object
   Dim oHtml  As HTMLDocument
   Dim lastRow As Variant
   Dim ModNum As Variant
   Dim doc As Object
   Dim tagx As Object
   Dim tRow As Object, tCel As Object
   Dim a As Object
   Dim l As Object
   Dim y As Long, z As Long, ws As Excel.Worksheet

                   'add the microsoft Internet Controls

   Set IE = CreateObject("InternetExplorer.Application")

   Workbooks("firsttry").Sheets("Feuil1").Activate 'Activate sheets("Feuil1")

   lastRow = Worksheets("Feuil2").Cells(Rows.count, "C").End(xlUp).row
       With IE
         d = 0
         For Each f In Sheets("Feuil2").Range("C2:C" & lastRow).Value
         ModNum = f
         d = d + 1
   IE.Visible = True

       .Visible = True
       .navigate "http://This an internal WebSite /consultation/preSearchMOD.do?clearBackList=true&CMH_NO_STORING_fromMenu=true"
 While IE.Busy Or IE.readyState <> 4: DoEvents: Wend
              'we ensure that the web Page is loaded completely


   Set itm = IE.document.getElementsByName("searchById")(0)
     If Not itm Is Nothing Then itm.Value = ModNum
      Set doc = IE.document
          Set tags = IE.document.getElementsByTagName("input")
             For Each tagx In tags
                If tagx.src = "http://ithis an internal WebSite/cmh/cmh/image/button_search.gif" Then  
              ' Search button ==>This Part reach That source of search button and click on it
               tagx.Click
            End If
           Next

    Call WaitIE(IE, 1000)
    For Each l In doc.getElementsByTagName("a")
    If l.href = "http://This an internal WebSite/cmh/consultation/preViewMODScheduling.do?fromSelect=true" Then  
                ' This Part search for the Href and click on it to changePage

   l.Click
   End If
   Next
   'Debug.Print elemCollection.Length
   Application.Wait (Now + TimeValue("0:00:03"))
   Workbooks("firsttry").Sheets("Feuil1").Range("A1:AK500").ClearContents 
    'Clear the Content of ActiveWorkbook  (A1:AK500)


  x = 2
  c = 1
  Application.Wait (Now + TimeValue("0:00:03"))
  On Error Resume Next
  While IE.Busy Or IE.readyState <> 4: DoEvents: Wend
     Set oHtml = New HTMLDocument
     oHtml.body.innerHTML = IE.document.body.innerHTML
      Set elemCollection = oHtml.getElementsByTagName("table")(62)      
                ' Search for Table 62 and Extract it into Sheet 1
       For Each tRow In elemCollection.Rows
       For Each tCel In tRow.Cells
       Cells(x, c) = tCel.innerText
       c = c + 1
       Next tCel
      c = 1
      x = x + 1
      Next tRow
      Next f
  End With
  Set IE = Nothing
 MsgBox "Done"
 End Sub

'-----------------------------------------------------------------------

 Sub WaitIE(IE As Object, Optional time As Long = 250)
 Dim i As Long
 Do
       Sleep time
       Debug.Print CStr(i) & vbTab & "Ready: " & CStr(IE.readyState = 4) & _
            vbCrLf & vbTab & "Busy: " & CStr(IE.Busy)
 i = i + 1
 Loop Until IE.readyState = 4 And Not IE.Busy
 End Sub

正如您在此代码中看到的，我得到了这个变量ModNum，它允许我使用位于此表C列中的值，并从我们的内部网站中提取数据并在其前面打印然后传递给下一个值进行搜索

要恢复：从网站提取数据后，我想将这些数据放在column D

中该表中每个值的前面

任何人都可以用这点照亮我吗？

祝你好运

珀勒什

Answer 1

我创建了这个但是有没有更好的解决方案：

每行的前面我添加了我想要添加的数据名称：

我创建此代码以比较sheet1 FULLTRS official(TCM)中是否存在Range("A2:A")or Cells(i, 1)然后偏移到第4列并复制它

For i = 1 To 100
If Sheets("Feuil2").Range("E3").Value = "FullTRS official (TCM) " Then
If Sheets("Feuil1").Cells(i, 1) Like Sheets("Feuil2").Range("E3").Value Then
tex = "FullTRS official (TCM) "
 Set r = Cells.Find(What:=tex, After:=Cells(1), LookAt:=xlPart)
 r.Select
 ActiveCell.Offset(0, 3).Select
 Selection.Copy
 Sheets("Feuil2").Cells(f, 3).Select
 ActiveCell.Paste

End If
End If
Next
Next f

--------感谢@Fayrouzouerghui

但是这个解决方案的问题是，如果第4行中的单词FULLTRS official(TCM)，它不会复制eG的第i行和第4列，然后它会转到第4行和第4行并复制数据然后将其粘贴到价值的其他页面

这部分代码无法正常工作

     Selection.Copy
     Sheets("Feuil2").Cells(f, 3).Select
     ActiveCell.Paste

所以我想知道是否有人可以提供帮助

Answer 2

如果要搜索该值并向右偏移，直到到达第4列所以尝试这可能它可以帮助

 Sub test()
 Dim tex As String
 Dim r As Range

   tex = "FullTRS official (TCM) "

 Set r = Cells.Find(What:=tex, After:=Cells(1), LookAt:=xlPart)
 r.Select
 ActiveCell.Offset(0, 3).Copy
  'type your deserved Task under this
  End Sub

此代码可帮助您选择所需的文本，然后使用ActiveCell.Offset(0, 3).Copy

复制前面的值

每个单元格的Excel Vba-fill数据

2 个答案: