从网页上导入数据的问题

123shusheng

     这是我在坛子里学到的例子，因为网页上的表比较复杂，所以我希望从第三列，开始导入数据，即每行的第一、第二列不导入，请问如何改，谢谢！


Private Sub W1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error Resume Next
If Not (pDisp Is W1.Object) Then Exit Sub
If St = False Then Exit Sub
Lurl = W1.LocationURL
    Dim txtData, TX As String
    Dim txtdata1 As String
    Dim ff
If Lurl = "http://www.ometal.com/price/index.asp?act=find&Prod" Then
    txtData = Me.W1.Object.Document.body.innerText
    If Left(txtData, 4) = " 已取消" Then
    MsgBox "目标网页没有正常打开，请检查网络连接。", vbOKOnly, "系统提示"
    Exit Sub
    End If
End If
Dim Tables As IHTMLElementCollection
Set Tables = W1.Document.getElementsByTagName("Table")
Dim Table1 As HTMLTable
Dim i As Integer
Dim j As Integer
Dim text1 As String
'Dim TX As String
Dim N As Integer '使用此参数用于确定是否找到了数据行
txtData = Me.W1.Object.Document.body.innerText '获取页面中的去除html的数据
    If Left(txtData, 4) = " 已取消" Then
    MsgBox "目标网页没有正常打开，请检查网络连接。", vbOKOnly, "系统提示"
    Exit Sub
    End If
    For Each Table1 In Tables
'M = 0 '行数置0，否则第二次运行在excel表中会增加上次运行总行数的空白行
    Dim Row As HTMLTableRow, Cell As HTMLTableCell
    N = 0
    For i = 0 To Table1.rows.length - 1      ' 逐行处理
       Set Row = Table1.rows(i)
       j = 0
           TX = Trim(Row.cells(0).innerText)
           If Left(Trim(Row.cells(0).innerText), 4) = "产品名称" Then N = 1  ' 找到需要的行，不要表头
             If N = 1 And Left(Trim(Row.cells(0).innerText), 5) <> ">> 首页" Then
                 If i > 1 Then M = M + 1
                   For Each Cell In Row.cells      ' 逐列处理
                       If i > 1 Then newBook.worksheets(1).cells(M, 1 + j) = Trim(Row.cells(j).innerText)
                         If i > 2 Then text1 = text1 & Trim(Row.cells(j).innerText) & ","
                         j = j + 1
                   Next
                         If i = 2 Then newBook.worksheets(1).cells(M, 1 + j) = Date
                         If Nz(text1) <> "" Then
                          text1 = text1 & Format(CDate(Date) - PP, "yyyy-m-d") & vbCrLf  ' 一行处理完毕后，去除行尾的逗号并加上回车
                         If i > 2 Then newBook.worksheets(1).cells(M, 1 + j) = Format(CDate(Date) - PP, "yyyy-m-d")
                        End If
                       End If
    Next
  Next

Set ff = Me.W1.Object.Document.all("__NextLink")
aa = ""
aa = ff.href
If aa = "" Then
              newBook.SaveAs Filename:=CurrentProject.Path & "\价格采集.XLS"  '
              newBook.Close
If MsgBox("数据己传输完毕,文件己保存到：" & CurrentProject.Path & "\价格采集.XLS" & vbCrLf & "现在查看和整理数据吗?", vbYesNo + vbDefaultButton1, "系统提示") = vbYes Then
             Dim newXls As Excel.Application
             Set newXls = CreateObject("Excel.Application")
             newXls.Visible = True
             newXls.UserControl = True
             newXls.Workbooks.Open CurrentProject.Path & "\价格采集.XLS"
End If
Me.命令9.Enabled = True
St = False
Else
W1.Navigate ff.href
End If
End Sub

todaynew

有j的地方多加2不就完事了

123shusheng

todaynew 发表于 2013-3-11 12:51
有j的地方多加2不就完事了

我按2楼的说法，将红色地方的1+j改为3+j，可是发现导出的数据左侧多了两列空行，并不是我想要的。
我的想法是：1、能够从左边第三列开始导入（第一、二列非数据，不需要导入）
            2、希望直接导入数据库的指定表内，我用查询进行调整
            3、我需要从表的第一行开始导入，以第一行作为字段名

    请大侠帮助，谢谢！

todaynew

123shusheng 发表于 2013-3-11 19:16
我按2楼的说法，将红色地方的1+j改为3+j，可是发现导出的数据左侧多了两列空行，并不是我想要的。
我的想 ...

For j=2 to Row.cells.count -1     ' 逐列处理
         If i > 1 Then newBook.worksheets(1).cells(M, 1 + j) = Trim(Row.cells(j).innerText)
         If i > 2 Then text1 = text1 & Trim(Row.cells(j).innerText) & ","
Next

123shusheng

todaynew 发表于 2013-3-11 19:31
For j=2 to Row.cells.count -1     ' 逐列处理
         If i > 1 Then newBook.worksheets(1).cells ...

已经按版主的意见修改了，明天上机测试，还有两个目的没有达到，请版主给个修改意见，谢谢！

123shusheng

今天测试了，可以实现从第三列开始导入，还有两个目的没有达到，（在3楼），请大侠指点，谢谢！

todaynew

123shusheng 发表于 2013-3-12 12:48
今天测试了，可以实现从第三列开始导入，还有两个目的没有达到，（在3楼），请大侠指点，谢谢！

  Dim rs As New ADODB.Recordset
    Dim ssql As String
    Dim i as long
    ssql="select * from 阁下的数据表名称"
    rs.Open ssql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    ....
    ....
    rs.addnew
    For j=2 to Row.cells.count -1     ' 逐列处理
          If i > 1 Then rs.fields(j-2).value = Trim(Row.cells(j).innerText)
    Next
    rs.update
    ....
    ....
    set rs=nothing

处理方法可参见《一网打尽》一文。

123shusheng

todaynew 发表于 2013-3-12 13:20
Dim rs As New ADODB.Recordset
    Dim ssql As String
    Dim i as long

坛子里关于网页数据导出的例子的确不多，可供参考的例子也不多，我好不容易才找到了这个例子，请好心的大侠帮我改改。我的要求是1、设个按钮，将网页中的表导入数据库,而不要利用EXCL中转。
           2、我要求从左侧第5列开始导入，因为左侧4列不是数据
           3、我需要表头（例子中不要表头）
谢谢！