Consultar Vários Rastreamentos dos Correios Excel

Objetivo: Disponibilizar uma planilha 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.

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

Abraço

Marcos Rieper