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