[RESOLVIDO]Copiar tabela da web

[Wagner.cwb]

Boa noite Amigos!

Recebi auxílio do Mikel e Everton no outro post. viewtopic.php?f=25&t=4875, desta vez solicito a ajuda para capturar tabelas.

Anteriormente, foi utilizado o script para obter os países e, funcionou perfeitamente, adaptei para as outras fontes e ótimo, mas esbarrei agora na captura de tabelas, tentei adaptar o código, porém só copia a primeira linha da tabela, tente criar um loop, mas acabei destruindo o
código ahahaha, bom, estou aprendendo, por isso estou pedindo novamente o tempo e ajuda de vocês.

arquivo:
https://drive.google.com/open?id=0B88ev ... W9WUENSOTg

A página base é: http://www.dondelopublico.com/ficha/

exemplo: http://www.dondelopublico.com/ficha/0004-0592

Necessito das tabelas Datos de indización e Evaluación de organismos nacionales de ciencia y técnica

Por favor, podem me ajudar novamente?

Código: Selecionar todos

Sub CaptureCountry()

Dim ie As Object
Dim iLin, iCount As Long

'instancia de objeto do IE e o torna visível
Set ie = CreateObject("internetexplorer.application")
ie.Visible = True

'Inicia o processo de varredura da lista.
For iLin = 2 To Plan1.UsedRange.Rows.Count
   
   'Verifica se existe algum NLM informado
   'na linha atual da coluna A da planilha.
   'Caso encontre, a rotina irá interromper o laço.
   If Plan1.Cells(iLin, 1).Value = "" Then Exit For
   
   'Carrega a página atual, utilizando o endereço da coluna C.
   ie.navigate Plan1.Cells(iLin, 3).Value

   'Aguarda carregamento da página.
   Do While ie.busy: VBA.DoEvents: Loop
     
   'Verifica se houve algum resultado da pesquisa.
   'Caso não haja, irá para a próxima linha.
   If ie.document.getelementsbytagname("li").Length <= 0 Then GoTo nextLinha
   
   For iCount = 0 To ie.document.getelementsbytagname("li").Length - 1
    If ie.document.getelementsbytagname("li")(iCount).innertext Like "País*" Then
      'Captura o país da NLM e envia para  a planilha.
      Plan1.Cells(iLin, 2).Value = VBA.Trim(VBA.Replace( _
        ie.document.getelementsbytagname("li")(iCount).innertext, "País:", ""))
       GoTo nextLinha 'Força saída do laço.
    End If
   Next iCount
   
   'Caso não encontre nada no teste acima,
   'redireciona a rotina para a próxima linha.
   GoTo nextLinha

nextLinha: 'Referência pra próxima linha.
   
Next iLin

'Limpa o objeto ie
Set ie = Nothing

End Sub

Obrigado, abraços!

[Wagner.cwb]

Boa noite amigos!

para evitar o trabalho, venho pedir a ajuda de vocês para aprender.

Por gentileza, podem explicar como funciona esta parte do código?
como devo interpretar cada linha?
de repente assim eu já tenha condições de criar, obrigado!

Código: Selecionar todos

'Caso não haja, irá para a próxima linha.
   If ie.document.getelementsbytagname("li").Length <= 0 Then GoTo nextLinha
   
   For iCount = 0 To ie.document.getelementsbytagname("li").Length - 1
    If ie.document.getelementsbytagname("li")(iCount).innertext Like "Editorial*" Then
      'Captura o país da NLM e envia para  a planilha.
      Plan1.Cells(iLin, 9).Value = VBA.Trim(VBA.Replace( _
        ie.document.getelementsbytagname("li")(iCount).innertext, "Editorial:", ""))
       GoTo nextLinha 'Força saída do laço.
    End If

[Mikel Silveira Fraga]

Wagner, bom dia.

Vamos a explicação:

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

Código: Selecionar todos

If ie.document.getelementsbytagname("li").Length <= 0 Then GoTo nextLinha

Esse código acima realiza um teste, verificando quanto elementos com a Tag "li", existem dentro da página carregada. Caso a resposta seja Menor/Igual a 0, ele executa a instrução GoTo, desviando a sequencia da rotina para uma linha mais abaixo, onde se encontra a expressão "nextLinha:".

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

Código: Selecionar todos

For iCount = 0 To ie.document.getelementsbytagname("li").Length - 1
Next iCount

No bloco For/Next, é iniciado um laço, definido pela quantidade de elementos com a Tag "li" existentes. Como funciona:
- O fato do contador do laço começar com 0 e, no final do comando, termos o Length -1, se da pelo fato dos Elementos Html, acessados pelo VBA, trabalharem suas referências com índice. Então, se temos 40 Tags "li" na página, o 1º possui o índice 0, o 23º possui o índice 22 e o 40º possui o índice 39. Por isso que no lugar de iniciar do 1 ao 40 (referencia numérica), o contador vai de 0 a 39 (em nosso exemplo: Length -1 = 40 - 1);

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

Código: Selecionar todos

If ie.document.getelementsbytagname("li")(iCount).innertext Like "Editorial*" Then

Dentro do lanço iniciado, é feito um teste para cada Tag "li", conforme pode ser visto no código acima. Aqui é testado o texto existente nestas Tags, em específico, analisando qual Tag possui o texto que começa com a expressão "Editorial". O Operador Like é utilizado para manipular esse tipo de análise. O Asteriscos(*) faz referencia a qualquer tipo de texto existente nesse ponto em diante. Então, conforme código acima, ele busca pelo texto "Editorial: Nome do País", independente do país que foi carregado.
' ----------------------------------------------------------------------------------------------------------------------------

Código: Selecionar todos

Plan1.Cells(iLin, 9).Value = VBA.Trim(VBA.Replace( _
        ie.document.getelementsbytagname("li")(iCount).innertext, "Editorial:", ""))
        GoTo nextLinha 'Força saída do laço.

Por último, quando o texto com a condição editorial é localizado, ele envia o texto para a célula pré-definida como Cells(iLin, 9). Para isso, foi utilizado duas instruções do Visual Basic:
- Replace: essa instrução pega um texto e substitua partes referenciadas por outras. Como o texto carregado na Tag "li" é "Editorial: Nome do Pais", ele substitui a parte do "Editorial:" por nenhum valor(""), restando apenas a parte do texto com " Nome do País".
- Trim: como observado no texto resultante acima, houve um espaço em branco antes do nome. Essa função atual remove todos os espaços em branco existente antes/depois do texto. Ele não remove os espaços existente entre palavras.
Depois de capturar o texto para a planilha, ele novamente executa a instrução Goto, indo para o mesmo caminho já explicado anteriormente. Dessa forma, é forçada a saída do laço, já que o texto desejado foi capturado e não existindo mais a necessidade de percorrer os demais elementos da página.

' ----------------------------------------------------------------------------------------------------------------------------
Não é algo fácil de se explicar por aqui, mas todas as instruções utilizadas nesse código, são funções básicas de programação. Eu aconselho você a procurar estudar o VBA Básico e, para as interações com a Web, aprender o básico da Estrutura de Html/Css.

Espero ter ajudado. Abraços!!!!

[Wagner.cwb]

Obrigado Mikel, ajudou sim. Realmente preciso estudar mais os conceitos básicos de vba, o seu bom exemplo é motivador.
Abraço!

[Wagner.cwb]

Boa tarde amigos!

estou buscando copiar tabelas de um site, evolui um pouco mais, vi que existe no excel uma opção --Dados ->obter dados externos ->da Web
Com o assistente do excel, rodou uma macro que me atende, porém ainda estou com dificuldade de como automatizá-la, ou seja, uma forma de criar o loop até terminar todas as tabelas, por favor, podem me ajudar novamente?

Código: Selecionar todos

Sub CapturarTabelaQualis()
'
' CapturarTabelaQualis Macro
' TabelaQualis
'
' Atalho do teclado: Ctrl+t
'
    Range("C1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.dondelopublico.com/ficha/0004-0592", Destination:=Range( _
        "$C$1"))
        .Name = "0004-0592"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("C21").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.dondelopublico.com/ficha/0007-1234", Destination:=Range( _
        "$C$21"))
        .Name = "0007-1234"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("C41").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.dondelopublico.com/ficha/0007-6813", Destination:=Range( _
        "$C$41"))
        .Name = "0007-6813"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    ActiveWindow.SmallScroll Down:=28
    Range("C61").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.dondelopublico.com/ficha/0010-4140", Destination:=Range( _
        "$C$61"))
        .Name = "0010-4140"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub

Arquivo: https://drive.google.com/open?id=0B88ev ... nVoMmppNW8

[Mikel Silveira Fraga]

Wagner, boa noite.

Bem, não tive como ver seu modelo, mas pelo que entendi, acredito que você tenha uma lista com os números da ficha, correto?

Se tiver, você poderia adicionar um laço que passasse por toda a lista, capturando seu número que armazenando em uma variável.

Com essa parte feita, altere a linha abaixo:

Código: Selecionar todos

"URL;http://www.dondelopublico.com/ficha/0004-0592", Destination:=Range( _

Pela seguinte linha:

Código: Selecionar todos

"URL;http://www.dondelopublico.com/ficha/" & NrFicha, Destination:=Range( _

Onde, NrFicha é o nome da variável que recebeu o número da ficha.

Teste e nos retorne, ok. Abraços!!!!

[Wagner.cwb]

Obrigado Mikel, ajudou demais, abraço!

[Wagner.cwb]

segue o código final, caso alguém tenha necessidade semelhante.

Código: Selecionar todos

Sub capturar_tabela()

 Dim ISNN As String
 Dim I As Integer
 
 I = 1
Do While Range("C" & I).Value <> ""

ISNN = Range("C" & I).Value
 
   With ActiveSheet.QueryTables.Add(Connection:= _
       "URL;http://www.dondelopublico.com/ficha/" & ISNN, Destination:=Range( _
       "D" & I))
       .name = "ISNN"
       .FieldNames = True
       .RowNumbers = False
       .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        ActiveCell.Offset(20, 0).Select
   End With
   
I = I + 20
Loop

End Sub

Capturar Tabelas.rar

(218.37 KiB) Baixado 385 vezes

[federico]

hola wagner
soy el administrador de la web dondelopublico.com
si tenías necesidad de la base de datos, podías enviarme un mail sin necesidad de chupar todo el contenido así sin permiso y sistemáticamente.

saludos