Calcular Frete nos Correios – Tabela de Prazo de Entrega e Valores – Planilha Excel VBA

Calcular Frete nos Correios – Tabela de Prazo de Entrega e Valores – Planilha Excel VBA

Objetivo da Planilha: Calcular frete nos correios. Planilha em Excel VBA calculador de frete correios que realiza a pesquisa ao XML para determinar preços e prazos correios, conforme o serviço, origem, destino e dimensões dos pacotes. Realiza esta tarefa para todos os pacotes de uma só vez. Veja o novo Rastreamento correio no excel.

Calcular Frete nos Correios

Esta Tabela Frete Correios Excel foi ideia foi enviada pelo amigo marcospaf através do Fórum do Guia do Excel, e achei que poderia ser útil para a nossa comunidade.

Com base na ideia, resolvi criar a planilha de frete dos correios, que serve para ajudar a calcular o prazo de entrega e orçar frete. Ela contém uma tabela com calculador de preços e prazos das entregas, de acordo com serviço, peso e dimensões, tipo de serviços de entrega (Pac, Sedex, Sedex 10, Sedex 12, mundi) para que você possa escolher o melhor resultado. 

 A planilha funciona da seguinte forma, são digitados os campos:

  1. CEP Origem: CEP de onde será despachado o pacote;
  2. CEP Destino: CEP do destino para o qual será enviada a encomenda;
  3. Serviço: Tipo do serviço disponibilizado pelos correios, conforme lista passada pelo próprio correio;
  4. Peso: Peso do pacote;
  5. Comprimento: Comprimento do pacote;
  6. Largura: Largura do pacote;
  7. Altura: Altura do pacote.

Abaixo o código VBA que monta a planilha automaticamente:

Sub lsConsultaProdutoCorreios()

    Application.ScreenUpdating = False

    Dim lUltimaLinhaAtiva As Long

    Worksheets("Rastreamentos").Select

    lUltimaLinhaAtiva = Worksheets("Lista de encomendas").Cells(Worksheets("Lista de encomendas").Rows.Count, 1).End(xlUp).Row + 1

    For i = 6 To lUltimaLinhaAtiva
        
        DoEvents
        
        With ActiveWorkbook.Connections("Conexão23")
            .Name = "Conexão23"
            .Description = ""
        End With
        Range("A1:C200").Select
        With Selection.QueryTable
            .Connection = _
            "URL;http://ws.correios.com.br/calculador/CalcPrecoPrazo.aspx?nCdEmpresa=&sDsSenha=&nCdServico=" & Worksheets("Lista de Encomendas").Range("D" & i).Value & "&sCepOrigem=" & Worksheets("Lista de Encomendas").Range("A" & i).Value & "&sCepDestino=" & Worksheets("Lista de Encomendas").Range("B" & i).Value & "&nVlPeso= " & Worksheets("Lista de Encomendas").Range("E" & i).Value & "&nCdFormato=1&nVlComprimento=" & Worksheets("Lista de Encomendas").Range("F" & i).Value & "&nVlAltura=" & Worksheets("Lista de Encomendas").Range("H" & i).Value & "&nVlLargura=" & Worksheets("Lista de Encomendas").Range("G" & i).Value & "&nVlDiametro=0&sCdMaoPropria=N&nVlValorDeclarado=0&sCdAvisoRecebimento=N&StrRetorno=xml"
            .WebSelectionType = xlAllTables
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        
        ActiveWorkbook.Connections("Conexão23").Refresh
        
        Worksheets("Lista de Encomendas").Range("I" & i).Value = Worksheets("Rastreamentos").Range("K3").Value
        Worksheets("Lista de Encomendas").Range("J" & i).Value = Worksheets("Rastreamentos").Range("N3").Value
    Next i
    
    Worksheets("Lista de encomendas").Select
    
    Application.ScreenUpdating = True
    
End Sub

 

Baixe a planilha

Abraço

Marcos Rieper

 

____________

 

Links Úteis: Correios http://www.correios.com.br