Este fórum está sendo desativado

[Hudson]

Estou tentando copiar para o excel os dados de usuários a partir do id da página de cada usuário e transportar para o excel

Tenho o seguinte endereço do primeiro usuário: https://intranet/?p=1 onde muda apenas o final= p=2, p=3 e assim por diante, então fiz a macro desta forma:

Código: Selecionar todos

Sub Macro4()
' Macro4 Macro
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://intranet/?p=1", Destination:=Range("$J$1"))
        .Name = "?p=1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("J3:J5").Select
    Selection.Copy
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("J:J").Select
    Application.CutCopyMode = False
    Selection.QueryTable.Delete
    Selection.ClearContents
    
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://intranet/?p=2", Destination:=Range("$J$1"))
        .Name = "?p=2"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("J3:J5").Select
    Selection.Copy
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("J:J").Select
    Application.CutCopyMode = False
    Selection.QueryTable.Delete
    Selection.ClearContents
End Sub

veja, consigo copiar o usuário "1" seleciono os dados que preciso, copio e colo na coluna "d1" os dados que preciso e apago para que eu possa copiar o segundo usuário: copio o que quero colo na colna "d2" e após apago as demais informações.

Até ai sem problema. O problema é que tenho 150.000 mil usuários, ou seja, preciso adaptar esta formula para que ela tenha um loop até 150.000 mil copiando e colando cada usuário até o término.

Será que da?

[osvaldomp]

... tenho 150.000 mil usuários ...

Você tem 150 milhões de usuários? Ou seria 150 mil ?

Faça um teste com o código abaixo. Coloquei até 3 usuários somente para efeitos de teste.

Código: Selecionar todos

Sub Macro4V2()
' Macro4 Macro
   Dim i As Long
    For i = 1 To 3
      With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://intranet/?p=" & i & """", Destination:=Range("$J$1"))
        .Name = """?p=" & i & """"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
      End With
    Range("J3:J5").Copy
    Cells(Rows.Count, 4).End(3)(2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("J:J") = ""
    Next i
End Sub

[Hudson]

Olá osvaldomp Tudo joia?

Escrevi errado, são 150 mil.

Testando a sua macro, ela roda legal, mas esta repetindo os resultados.

Exemplo quando acesso o link: https://intranet/?p=1
Ele traz os dados do usuário carlos, 30 anos de idade, São Paulo.

No resultado da sua macro ele puxa 3 resultados mas não dos usuários p=2 e p=3 ele puxa 3 resultados do usuário p=1

[osvaldomp]

Olá, Hudson.

Vamos por tentativas pois como eu não tenho acesso à sua rede eu não consigo testar o código aqui.

Experimente colocar as linhas abaixo no lugar das que estão no código anterior.

Código: Selecionar todos

     With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://intranet/?p=" & i & "", Destination:=Range("$J$1"))
        .Name = "?p=" & i & ""

[Hudson]

Olá Osvaldo,

Cara sem palavras para agradecer a sua ajuda. Funcionou como uma luva.

Muitíssimo obrigado amigo!

[Hudson]

Olá Osvaldo, tudo joia?

Cara, estou tentando puxar mais de 500 contato com a macro, mas por algum motivo ela trava após 300, será que da para corrigir isso?

segue ela com a versão final:

Código: Selecionar todos

Sub Macro4V2()
' Macro4 Macro
   Dim i As Long
    For i = 301 To 600
    
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://intranet/?p=" & i & "", Destination:=Range("$J$1"))
        .Name = "?p=" & i & ""
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
      End With
    Range("J3:J5").Copy
    Cells(Rows.Count, 2).End(3)(2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("J:J") = ""
    Next i
    
        Columns("C:C").Select
    Selection.Replace What:="  Maiores informações: ", Replacement:="", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("D:D").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    
    ActiveWorkbook.Save
    MsgBox "Download de dados efetuados com sucesso!"
End Sub

[osvaldomp]

[quote="Hudson"]

... estou tentando puxar mais de 500 contato com a macro, mas por algum motivo ela trava após 300,...
Ao travar, qual a linha do código que é destacada em amarelo?
Qual a mensagem de erro que é exibida pelo Excel?

segue ela com a versão final:
Informe com exatidão o que você alterou desde a versão original que passei e que funcionou no início.
Para baixar até 300 registros funcionou corretamente? E acima de 300 não funcionou? O que exatamente você alterou para baixar acima de 300?

[Hudson]

Olá Osvaldo,

Quando a planilha trava ela não mostra linha pois trava o excel, preciso fecha-lo pelo gerenciador


Sobre a versão final só alterei este trecho:

Código: Selecionar todos

 Columns("C:C").Select
    Selection.Replace What:="  Maiores informações: ", Replacement:="", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("D:D").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    
    ActiveWorkbook.Save
    MsgBox "Download de dados efetuados com sucesso!"

Para baixar 300 registros funciona, acima disso ele trava todo excel sendo necessário fecha-lo pelo gerenciador de arquivos.

[osvaldomp]

Olá, Hudson.
Entendi.
Por favor rode o código abaixo no seu arquivo e informe qual o número que será exibido na Caixa de Mensagem.

Código: Selecionar todos

Sub ContaWQ()
 MsgBox ActiveWorkbook.Connections.Count
End Sub

[Hudson]

Olá Osvaldo. após rodar o código o número exibido é 406

[osvaldomp]

Olá, Hudson.
Esse número significa que as QTs não estão sendo deletadas após serem baixadas e o Excel vai acumulando até "transbordar" a memória da máquina e travar. Erro meu, peço desculpas. Imaginei erradamente que ao limpar a coluna a QT também seria deletada.

Acrescente no código a primeira linha abaixo (em vermelho) para deletar cada QT após baixá-la.
Essa alteração provavelmente eliminará também o problema que você apontou neste outro tópico
viewtopic.php?f=12&t=4131
...
...
Columns("J:J").QueryTable.Delete
Columns("J:J") = ""
Next i
...
...

obs. se você tiver uma cópia "limpa" do arquivo (quero dizer, uma cópia sem QTs baixadas), você pode fazer uma nova cópia dele e utilizar nela o código com a alteração acima, ou se você quiser aproveitar o arquivo que já está com uma parte das QTs baixadas (aquele que acusou 406) será preciso primeiro deletar as 406 QTs e depois rodar nele o código com a alteração acima.

Para deletar as 406 QTs rode a macro abaixo.

Código: Selecionar todos

Sub DeletaConexões()
 Dim QT As QueryTable
  For Each QT In ActiveSheet.QueryTables
   QT.Delete
  Next QT
End Sub

[Hudson]

Olá Osvaldo, tudo joia, fiz a alteração, mas aparentemente não passa de 200 contatos. A planilha trava completamente.

[osvaldomp]

Depois que travou você rodou o código do post #20557 ?

[Hudson]

Olá Osvaldo, então toda vez que trava não consigo fazer mais nada fico obrigado a encerrar pelo gerenciador.

Eu inseri a intranet no ar temporariamente e alterei o endereço para o link acessável. Se puder, tenta rodar por ai por favor, segue o código alterado:

Código: Selecionar todos

Sub Macro4V2()
' Macro4 Macro
   Dim i As Long
    For i = 1 To 10000
    
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;https://azenka.com.br/landing/?p=" & i & "", Destination:=Range("$J$1"))
        .Name = "?p=" & i & ""
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
      End With
    Range("J3:J5").Copy
    Cells(Rows.Count, 2).End(3)(2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("J:J").QueryTable.Delete
    Columns("J:J") = ""
    Next i
    
        Columns("C:C").Select
    Selection.Replace What:="  Maiores informações: ", Replacement:="", LookAt _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("D:D").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    


 Dim QT As QueryTable
  For Each QT In ActiveSheet.QueryTables
   QT.Delete
  Next QT


    
    MsgBox ActiveWorkbook.Connections.Count

End Sub

[osvaldomp]

Olá, Hudson.
Desculpe pela demora.

Teste o código abaixo que em lugar de utilizar o recurso Query Table, como o seu código original, ele busca e baixa somente os dados de interesse, visto que cada QT baixa quase 100 linhas de dados e aproveita somente 3.
Os resultados serão lançados nas colunas 'D:G', cada registro em uma linha, nesta ordem: nome, ID, telefone, e-mail.
Baixei aqui 1.000 registros em 17,5 minutos.

Código: Selecionar todos

Sub BaixaDadosIntra()
  Const URL = "https://azenka.com.br/landing/?p="
  Dim a(1 To 4), b
  Dim i As Long, s As String, T As Double, R As Long
  Dim oDom As Object
  T = Timer
  Set oDom = CreateObject("htmlfile")
  With CreateObject("MSXML2.XMLHTTP")
    For i = 1 To 5
      .Open "GET", URL & i, False
      .send
      If .ReadyState = 4 And .Status = 200 Then
        oDom.body.innerHTML = .responseText
      Else
        MsgBox "i = " & i & vbLf _
             & "Ready state: " & .ReadyState & vbLf _
             & "HTTP request status: " & .Status, vbExclamation, "Error"
        Set oDom = Nothing
        Exit Sub
      End If
      With oDom.body.Document.all.Item(5)
        b = Split(.Children(3).innerText, "|")
        a(1) = Trim(b(0)) 'nome
        a(2) = Trim(b(1)) ' ID
        s = .Children(4).innerText
        a(3) = Trim(Mid(s, InStr(s, ":") + 1))  ' telefone
        a(4) = Trim(.Children(6).innerText)     ' email
        Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(, 4).Value = a()
        R = R + 1
        DoEvents
      End With
    Next
  End With
  Set oDom = Nothing
  Columns("D:G").AutoFit
  MsgBox "BAIXADOS " & R & " REGISTROS EM " & vbLf & Format((Timer - T) / 86400, "hh:mm:ss")
End Sub

[Hudson]

Olá Osvaldo, muitíssimo obrigado pela ajuda, funcionou perfeitamente. Obrigado mesmo!