Consultar Vários Rastreamentos dos Correios Excel

Planilha para Consultar Vários códigos de rastreio dos Correios Excel que permite acompanhar o rastreamento correio no Excel.

Atenção: Os correios mudaram a forma como realizavam a consulta e por isso a planilha abaixo não funciona mais. 

Mas criamos uma nova planilha que realiza esta consulta de forma muito mais profissional

Clique no botão abaixo para ver detalhes da nova planilha de rastreamentos de pacotes nos correios.

Consultando muitos rastreamentos dos Correios no Excel pode ser feito de várias maneiras, dependendo da sua necessidade específica. Uma opção é criar uma planilha com uma coluna para cada código de rastreamento e uma linha para cada atualização de status. Você pode então usar a função de busca na internet do Excel para buscar automaticamente atualizações de status para cada código de rastreamento.

Outra opção é usar uma macro VBA para automatizar o processo. Você pode criar uma macro que lê os códigos de rastreamento de uma coluna na planilha e, em seguida, usa uma biblioteca de terceiros para buscar atualizações de status automaticamente.

Se você possui uma grande quantidade de códigos de rastreamento, é importante ter em mente que a consulta automatizada pode levar algum tempo, então é recomendável dividir essa tarefa em várias etapas. Além disso, é importante verificar as políticas dos Correios sobre a utilização de seus dados de rastreamento.

Esta planilha foi criada para facilitar o acompanhamento de encomendas do site dos correios, sem a necessidade de digitar um a um no site.

Para utilizar a planilha basta digitar os códigos dos rastreamentos na lista de pacotes e clicar no botão Consulta produto correios.

O Excel possui uma conexão com a página dos correios dos rastreamentos, alterando a informação de consulta utilizando VBA.

Abaixo a exibição de como fica o relatório:

O código fonte segue abaixo:

Sub lsTodososPacotes()
    Dim lUltimaLinhaAtiva As Long
    Dim lControle As Long
    
    Application.ScreenUpdating = False
    
    lUltimaLinhaAtiva = Worksheets("Lista de Encomendas").Cells(Worksheets("Lista de Encomendas").Rows.Count, 1).End(xlUp).Row
    lControle = 2
    
    lsLimparLista
    
    While lControle <= lUltimaLinhaAtiva
        lsConsultaProdutoCorreios Worksheets("Lista de Encomendas").Range("A" & lControle).Value
        
        lControle = lControle + 1
    Wend
    
    Worksheets("Lista de Rastreamentos").Select
    lsFormata
    Worksheets("Lista de Rastreamentos").Columns("A:D").EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "Dados de rastreamento atualizados!", , "Atualização"
    
End Sub

Sub lsConsultaProdutoCorreios(ByVal lPacote As String)
    On Error Resume Next

    Dim lUltimaLinhaAtiva As Long

    Worksheets("Rastreamentos").Select

    With ActiveWorkbook.Connections("Conexão23")
        .Name = "Conexão23"
        .Description = ""
    End With
    Range("A1:C200").Select
    With Selection.QueryTable
        .Connection = _
        "URL;http://websro.correios.com.br/sro_bin/txect01$.QueryList?P_LINGUA=001&P_TIPO=001&P_COD_UNI=" & lPacote
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    ActiveWorkbook.Connections("Conexão23").Refresh
    
    lUltimaLinhaAtiva = Worksheets("Rastreamentos").Cells(Worksheets("Rastreamentos").Rows.Count, 1).End(xlUp).Row + 1
    
    Range("A1:C" & lUltimaLinhaAtiva).Copy
    
    Worksheets("Lista de Rastreamentos").Select
    
    lUltimaLinhaAtiva = Worksheets("Lista de Rastreamentos").Cells(Worksheets("Lista de Rastreamentos").Rows.Count, 1).End(xlUp).Row + 2
    
    Range("A" & lUltimaLinhaAtiva).Select
    
    ActiveSheet.Paste
    
    Range("D" & lUltimaLinhaAtiva).Value = lPacote
    
    Range("A" & lUltimaLinhaAtiva & ":D" & lUltimaLinhaAtiva).Font.Bold = True
    
    Range("A" & lUltimaLinhaAtiva & ":D" & lUltimaLinhaAtiva).Select
    
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
End Sub

Sub lsLimparLista()

    Worksheets("Lista de Rastreamentos").Select
    Columns("A:Z").Select
    Range("C10").Activate
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
End Sub

Sub lsFormata()
    Range("A1:C1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 15
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A1").Value = "Lista de Rastreamentos"
End Sub

Download da Planilha de Consulta de Rastreamentos dos Correios Excel

Abaixo o download da planilha de consulta de rastreamentos dos Correios.