Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 69437 Skopiuj do schowka GUS PKD
Autor Wiadomość
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: 26-11-2020, 15:53   GUS PKD

Tematem będzie pobieranie danych z GUS-u.
Dla pokazania jak to działa będziemy pobierać numery PKD.

W załączniku pokazałem dwie wersje - Prod i Testową.
Dla wersji Prod konieczne będzie uzyskanie klucza API, które jest bezpłatne.
Na klucz czekałem 1 dzień.
Info tu:
Cytat:
https://api.stat.gov.pl/Home/RegonApi

Oczywiście PKD jest tylko przykładem, bo danych możemy wyciągnąć znacznie więcej.
W arkuszu "Nazwa raportu" dodałem spis co możemy pobrać podstawiając pod zmienną Nazwa_Raportu odpowiedni "BIR11Osxxxxxxxxxx".

Info:
Żeby pobrać PKD musimy posiadać numer REGON , bo WSDL nie przewiduje wyszukiwania po NIP-ie czy KRS-ie.

Nie jest to problem , bo mając NIP czy KRS bez problemu wyciągniemy REGON.
I tak po nitce do kłębka.

Kto chętny niech testuje, nie kosztuje to nic , nawet złamanego "Sasina". :mrgreen:

Gus.zip
Pobierz Plik ściągnięto 22 raz(y) 32.55 KB

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 395638 Skopiuj do schowka
 
 
Rafał B.
Exceloholic



Wersja: Win Office 2016
Pomógł: 33 razy
Posty: 232
Wysłany: 26-11-2020, 22:21   

Super sprawa, dzięki!

PS
Set objXml = Nothing dla świętego spokoju ;-)
_________________
Jest niemal niemożliwe nauczenie dobrego programowania uczniów, którzy byli narażeni na kontakt z BASIC: jako potencjalni programiści są okaleczeni, bez nadziei na poprawę. (Edsger Dijkstra, pionier informatyki).
Po części dotyczy również VBA.
ID posta: 395656 Skopiuj do schowka
 
 
Auditorius 
Exceloholic


Wersja: Win Office 2013
Posty: 185
Wysłany: 02-12-2020, 11:07   

@Marecki,

1) Kod super
2) Dodałem drobne modyfikacje nawet nie w kodzie ale w możliwościach arkusza (żeby oprócz numerków PKD wyświetlało się też rozszyfrowanie co dane PKD oznacza)
3) Przetestowałem na różnych PKD i okazuje się że GUS różnie ma opisane PKD w swojej bazie - dla jednych PKD stosuje odpowiedź z "0" na początku, dla innych nie - stąd modyfikacje w mapingach (ale to nie dotyczy kodu tylko jakości danych w bazie)

Natomiast brak możliwości sprawdzenia po NIPie to pewne ograniczenie.
'Podpiąłem' twój kod dot. BL ale on sprawdzi ok. 70% podmiotów - pozostałe skoro ich nie ma to nie pomoże w ustaleniu REGONu

W załączniku przykłady sprawdzeń z BL i spoza BL - dałoby radę podpiąć w pierwszym kroku sprawdzenie REGONu po NIPie a w drugim zaciąganie PKD ?
(bo podobne rozwiązanie zapodałeś wcześniej)

Kod:

' ******************* pobieramy REGON po NIPie ?
Set objXml = CreateObject("MSXML2.XMLHTTP")
    With objXml
    .Open "Post", sUrl, False
       
                .setRequestHeader "Content-Type", "application/soap+xml; charset=utf-8"
        .send (Soap)
        sID = VBA.Left$(Split(.responsetext, "<ZalogujResult>")(1), 20)

        Soap = FileTxt_to_string(ThisWorkbook.Path & "\Soap_DaneSzukajPodmioty.txt")
        Soap = VBA.Replace(Soap, "sNip", NIP)

        .Open "Post", sUrl, False
        .setRequestHeader "Content-Type", "application/soap+xml; charset=utf-8"
        .setRequestHeader "Sid", sID
        .send (Soap)

        Debug.Print Replace_Special_Char(.responsetext)

    End With
End Sub

REGON = RegEx_Tab("<REGON>(.*?)<\/REGON>", Resp)
            If IsArray(REGON) Then
                Cells(i, j + 4).Value = REGON
                           
                 End If


Function Replace_Special_Char(sStr As String) As String
    sStr = sStr & VBA.Replace(sStr, "&lt;", "<")
    sStr = sStr & VBA.Replace(sStr, "&gt;", ">")
    sStr = sStr & VBA.Replace(sStr, "&#xD;", vbNullString)
    Replace_Special_Char = sStr
End Function





Plik DaneSzukajPodmioty
Kod:

<soap:Envelope xmlns:soap="http://www.w3.org/2003/05/soap-envelope" xmlns:ns="http://CIS/BIR/PUBL/2014/07" xmlns:dat="http://CIS/BIR/PUBL/2014/07/DataContract">
    <soap:Header xmlns:wsa="http://www.w3.org/2005/08/addressing">
        <wsa:To>https://wyszukiwarkaregontest.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc</wsa:To>
        <wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/DaneSzukajPodmioty</wsa:Action>
    </soap:Header>
    <soap:Body>
        <ns:DaneSzukajPodmioty>
            <ns:pParametryWyszukiwania>
                <dat:Nip>sNip</dat:Nip>
            </ns:pParametryWyszukiwania>
        </ns:DaneSzukajPodmioty>
    </soap:Body>
</soap:Envelope>


GUS_v1.1 z BL REGON_PKD_lista.xlsm
Pobierz Plik ściągnięto 9 raz(y) 273.68 KB

Soap_DaneSzukajPodmioty.txt
Pobierz Plik ściągnięto 8 raz(y) 622 Bajtów

Gus_test.xlsm
Pobierz Plik ściągnięto 9 raz(y) 19.57 KB

_________________
Nobody's Perfect
ID posta: 395900 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2494 razy
Posty: 8280
Wysłany: 05-12-2020, 19:10   

Kod:
Sub Regon_z_Nip()
Const My_Key As String = "xxxxxxxxxxxxxx"    'Tu wpisz swój klucz z GUS-u
Const sURL As String = "https://wyszukiwarkaregon.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc"
Dim Nazwa_Raportu As String
Dim objXml As Object
Dim Soap As String
Dim sID As Variant
Dim Resp As String
Dim REGON As Variant
Dim Nip As String
Dim i As Long
Dim j As Long
Dim PKD As Variant
Dim tmp As Variant

    Range("D2:z5").ClearContents
    Nazwa_Raportu = Arkusz2.Range("A7").Value
    Soap = FileTxt_to_string(ThisWorkbook.Path & "\Zaloguj.txt")
    Soap = VBA.Replace(Soap, "theUsersKey", My_Key)

    Set objXml = CreateObject("MSXML2.ServerXMLHTTP.6.0")


    '***********  Pobieramy numer sesji - SID połączenia, który wygasa po wywołaniu metody Wyloguj lub po upływie 60 minut.
    With objXml

        .Open "Post", sURL, False
        .setRequestHeader "Content-Type", "application/soap+xml; charset=utf-8"
        .send (Soap)

        If .Status <> 200 Then
            MsgBox Status_HTTP(.Status), vbCritical
            Exit Sub
        End If
        Resp = .responsetext

        tmp = RegEx_Tab("<ZalogujResult>(.*?)<\/ZalogujResult>", Resp)

        If Not IsArray(tmp) Then
            MsgBox "Prawdopodobnie podałeś zły klucz API !", vbCritical
            Exit Sub
        End If

        sID = tmp(0)
    End With


    '***************   Pobieramy właściwe dane
    For i = 2 To 5
        With objXml
            Nip = Arkusz1.Cells(i, 1).Value

            Soap = FileTxt_to_string(ThisWorkbook.Path & "\nip.txt")
            Soap = VBA.Replace(Soap, "sNip", Nip)

            .Open "Post", sURL, False
            .setRequestHeader "Content-Type", "application/soap+xml; charset=utf-8"
            .setRequestHeader "Sid", sID
            .send (Soap)
            Resp = Replace_Special_Char(.responsetext)

            REGON = RegEx_Tab("<Regon>(.*?)</Regon>", Resp)
            If IsArray(REGON) Then
                For j = 0 To UBound(REGON)
                    Cells(i, j + 2).Value = REGON(j)
                Next j
            End If

        End With

    Next i

End Sub


Nip.txt
Pobierz Plik ściągnięto 15 raz(y) 611 Bajtów

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 396061 Skopiuj do schowka
 
 
jarekkk
Exceloholic


Posty: 172
Wysłany: 22-02-2021, 16:29   

Witam,

Czy jest szansa na narzędzie/kod, w którym na podstawie NIP otrzymamy zwrotnie takie informacje jak nazwa, miejscowość, ulica, nr nieruchomości, nr lokalu, kod pocztowy, miejscowość poczty? Jeśli nie, proszę o usunięcie tego zapytania/posta....( :oops: )

Pozdrawiam Jarek.
ID posta: 400848 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe