Planilha Excel de rastreamento de pacotes do correio - Versão 2

Planilha Excel de rastreamento de pacotes do correio - Versão 2

Objetivo: Disponibilizar planilha excel para rastrear pacotes do correio versão 2.

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.

Acessar

Esta planilha tem por objetivo controlar entregas ou recebimentos de pacotes dos correios.

Você deve alimentar a coluna de Pacotes com os números dos rastreamentos dos correios, e nas colunas Produto e Cliente você deve digitar as informações pertinentes para facilitar a identificação.

Ao concluir clique no botão Rastreamento correio no Excel o sistema irá realizar uma consulta ao Webservice dos correios e retornar as informações dos rastreamentos preenchendo esta planilha principal e também a planilha que lista todo o caminho do rastreamento que consta na base dos correios.

Abaixo o código fonte VBA que realiza a consulta a base dos correios e atualiza a situação da planilha, além de criar um hiperlink entre o código do rastreamento e o seu histórico.

A planilha realiza a busca diretamente do website dos correios e é muito útil para controlar as encomendas de clientes e fornecedores despachadas pelos correios.

Dim lEndereco As Long

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
        DoEvents
        lsConsultaProdutoCorreios Worksheets("Lista de Encomendas").Range("A" & lControle).Value
        
        Worksheets("Lista de Encomendas").Select
        Range("A" & lControle).Select
        
        Selection.Hyperlinks.Delete
                           
        Range("B" & lControle).Value = Sheets("Lista de Rastreamentos").Range("A" & lEndereco).Value
        Range("C" & lControle).Value = Sheets("Lista de Rastreamentos").Range("B" & lEndereco).Value
        Range("D" & lControle).Value = Sheets("Lista de Rastreamentos").Range("C" & lEndereco).Value
        
        If Range("B" & lControle).Value <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                "'Lista de Rastreamentos'!A" & lEndereco, TextToDisplay:=Selection.Value
        End If
            
        lControle = lControle + 1
    Wend
    
    Worksheets("Lista de Rastreamentos").Select
    lsFormata
    Worksheets("Lista de Rastreamentos").Columns("A:D").EntireColumn.AutoFit
    Worksheets("Lista de Encomendas").Columns("A:F").EntireColumn.AutoFit
    Worksheets("Lista de Encomendas").Select
    
    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
    Worksheets("Rastreamentos").Range("A1:Z50000").ClearContents

    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
    
    lEndereco = lUltimaLinhaAtiva + 1
    
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"
    
    Range("D1").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "'Lista de Encomendas'!A1", TextToDisplay:="Lista de Encomendas"
End Sub

Abraço

Abraço

Marcos Rieper