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 2021
Pomógł: 2607 razy
Posty: 8689
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_v2.xlsm
Pobierz Plik ściągnięto 284 raz(y) 35.8 KB

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

FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
Ostatnio zmieniony przez Marecki 07-05-2022, 17:56, w całości zmieniany 3 razy  
ID posta: 395638 Skopiuj do schowka
 
 
Rafał B. 
ExcelSpec



Wersja: Win Office 2021
Pomógł: 76 razy
Posty: 468
Wysłany: 26-11-2020, 22:21   

Super sprawa, dzięki!

PS
Set objXml = Nothing dla świętego spokoju ;-)
_________________
Częstym błędem jest zakładanie, że autorzy niezrozumiałego kodu będą w jakiś sposób potrafili wyrazić się jasno i klarownie w komentarzach. Kevlin Henney
ID posta: 395656 Skopiuj do schowka
 
 
Auditorius 
Stały bywalec Excelforum


Wersja: Win Office 2013
Pomógł: 1 raz
Posty: 324
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 278 raz(y) 273.68 KB

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

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

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



Wersja: Win Office 2021
Pomógł: 2607 razy
Posty: 8689
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 207 raz(y) 611 Bajtów

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

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


Posty: 227
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
 
 
Marecki 
Excel Expert



Wersja: Win Office 2021
Pomógł: 2607 razy
Posty: 8689
Wysłany: 25-02-2021, 10:31   

Szansa wygląda tak jak w załączniku.

GUS_v1.0(1).xlsm
Pobierz Plik ściągnięto 280 raz(y) 32.02 KB

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

FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
Ostatnio zmieniony przez Marecki 26-02-2021, 10:42, w całości zmieniany 1 raz  
ID posta: 400973 Skopiuj do schowka
 
 
jarekkk
Exceloholic


Posty: 227
Wysłany: 26-02-2021, 10:28   

Witaj Marecki,

Dokładnie o to chodziło, tego potrzebowałem.
MARECKI WIELKIE WIELKIE DZIĘKI!

PS
To co robisz/robicie jest niesamowite.

Pozdrawiam Jarek.
ID posta: 401042 Skopiuj do schowka
 
 
pczypek
Świeżak


Wersja: Win Office 2019
Posty: 1
Wysłany: 10-09-2021, 08:23   

Hej!

Marecki, czy możesz jeszcze raz udostępnić zip z pobieraniem PKD z GUS? Niestety, aktualnie przy pobraniu 404.

Z góry wielkie dzięki!

Pozdrawiam,
Patryk
ID posta: 409071 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2021
Pomógł: 2607 razy
Posty: 8689
Wysłany: 30-09-2021, 04:33   

pczypek, załącznik poprawiony - dodany do pierwszego postu.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 409681 Skopiuj do schowka
 
 
mwrevo 
Świeżak


Wersja: Win Office 2019
Posty: 2
Wysłany: 03-07-2023, 14:10   

Dzień dobry,
Dziękuję Panu Mareckiemu za udostępnione pliki. Mam natomiast dwa problemy:

1. Plik GUS_v1.0 - w niektórych podmiotach plik uzupełnia błędnie nr nieruchomości. Sprawdzałem formatowanie komórek, przestawiłem na "tekst" przed importem z GUS - to nie naprawiło problemu. Przedsiębiorca o nr NIP: 1070031466 ma numer nieruchomości 12/14 a Excel wpisuje 45274 ... nawet nie wiem jak się za to zabrać tym bardziej, że na stronie www GUSu wyświetla się prawidłowo.

2. Plik GUS_v2 - który pobiera PKD - czy można tak zrobić by pobierał dla większej ilości podmiotów PKD i żeby działał tak jak plik GUS_v1.0?

Panowie, nie ma opcji żebym to sam swoja głową ogarnął... za pomoc z góry dziękuję.
Mam swoją bazę Klientów w Excelu, jest w niej dużo błędów bo przypadkowe osoby wprowadzały dane. Po NIP chcę pobrać nazwę i adres, a w drugim pliku po numerze REGON PKD... siedzę nad tym piąty dzień :roll:

Info dla Admina: podczas rejestracji konta mój e-mail którego używam od 20 lat dostał bana a nic nie zrobiłem. Próbowałem się zarejestrować na dwa e-maile które są na GMailu - nie dało się.

Pozdrawiam!
ID posta: 428770 Skopiuj do schowka
 
 
mwrevo 
Świeżak


Wersja: Win Office 2019
Posty: 2
Wysłany: 05-07-2023, 12:10   

Rozwiązałem problem źle wyświetlanych numerów nieruchomości, jednak nie mogę na forum wstawić załącznika z poprawionym plikiem Excela bo najwidoczniej nowi użytkownicy forum nie mają takiej możliwości. Poniżej działający kod do pliku Mareckiego GUS_v1.0(1).xlsm Dodatkowo należy kolumny z danymi zmienić na "tekstowe". Na tą chwilę wydaje się działać poprawnie.

Kod:
Option Explicit

Sub Pobierz_Dane()
    Const My_Key As String = "xxxxxxxxxxxxxxxxxxxx"  'Tu wpisz swój klucz z GUS-u
    Const sURL As String = "https://wyszukiwarkaregon.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc"
    Dim objXml As Object
    Dim Soap As String
    Dim sID As Variant
    Dim Resp As String
    Dim Nip As String
    Dim i As Long
    Dim Dane As Variant
    Dim ws As Worksheet
   
    Set ws = ThisWorkbook.Worksheets("Arkusz1")  ' Zmienić nazwę arkusza na właściwą
   
    'Koperta do logowania
    Soap = Soap & "<soap:Envelope xmlns:soap=""http://www.w3.org/2003/05/soap-envelope"" xmlns:ns=""http://CIS/BIR/PUBL/2014/07""> <soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">"
    Soap = Soap & "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/Zaloguj</wsa:Action>"
    Soap = Soap & "<wsa:To>https://wyszukiwarkaregon.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc</wsa:To>"
    Soap = Soap & "</soap:Header><soap:Body><ns:Zaloguj><ns:pKluczUzytkownika>" & My_Key & "</ns:pKluczUzytkownika></ns:Zaloguj></soap:Body></soap:Envelope>"

    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

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

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

        sID = Dane(0)
    End With

    Erase Dane

    '***************   Pobieramy właściwe dane
    For i = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        With objXml
            Nip = ws.Cells(i, 1).Value

            'Koperta dla nip
            Soap = "<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 = Soap & "<soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">"
            Soap = Soap & "<wsa:To>https://wyszukiwarkaregontest.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc</wsa:To>"
            Soap = Soap & "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/DaneSzukajPodmioty</wsa:Action>"
            Soap = Soap & "</soap:Header><soap:Body><ns:DaneSzukajPodmioty><ns:pParametryWyszukiwania><dat:Nip>" & Nip & "</dat:Nip></ns:pParametryWyszukiwania></ns:DaneSzukajPodmioty></soap:Body></soap:Envelope>"

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

        Resp = Replace(Resp, vbLf, "")
        Dane = RegEx_Tab("<dane>(.*?)<\/dane>", Resp)
        Dane(0) = "<dane>" & Dane(0) & "</dane>"

        ws.Cells(i, 2).Value = FilterXMLData(Dane(0), "//Regon")
        ws.Cells(i, 3).Value = FilterXMLData(Dane(0), "//Nazwa")
        ws.Cells(i, 4).Value = FilterXMLData(Dane(0), "//Miejscowosc")
        ws.Cells(i, 5).Value = FilterXMLData(Dane(0), "//Ulica")
        ws.Cells(i, 6).Value = FilterXMLData(Dane(0), "//NrNieruchomosci")
        ws.Cells(i, 7).Value = FilterXMLData(Dane(0), "//NrLokalu")
        ws.Cells(i, 8).Value = FilterXMLData(Dane(0), "//KodPocztowy")
        ws.Cells(i, 9).Value = FilterXMLData(Dane(0), "//MiejscowoscPoczty")
    Next i

    Set objXml = Nothing
    Erase Dane

End Sub

Function RegEx_Tab(ByVal Pattern As String, ByVal Text As String) As Variant
    Dim objRegEx As Object
    Dim objMatches As Object
    Dim objMatch As Object
    Dim arrMatches() As Variant
    Dim i As Long
   
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = Pattern
    End With
   
    If objRegEx.test(Text) Then
        Set objMatches = objRegEx.Execute(Text)
        ReDim arrMatches(0 To objMatches.Count - 1)
       
        i = 0
        For Each objMatch In objMatches
            arrMatches(i) = objMatch.SubMatches(0)
            i = i + 1
        Next objMatch
       
        RegEx_Tab = arrMatches
    Else
        RegEx_Tab = Empty
    End If
   
    Set objRegEx = Nothing
    Set objMatches = Nothing
End Function

Function Replace_Special_Char(ByVal Text As String) As String
    Replace_Special_Char = Replace(Text, "&amp;", "&")
    Replace_Special_Char = Replace(Replace_Special_Char, "&gt;", ">")
    Replace_Special_Char = Replace(Replace_Special_Char, "&lt;", "<")
    Replace_Special_Char = Replace(Replace_Special_Char, "&quot;", """")
    Replace_Special_Char = Replace(Replace_Special_Char, "&apos;", "'")
End Function

Function FilterXMLData(ByVal XMLData As String, ByVal XPath As String) As Variant
    Dim xmlDoc As Object
    Dim nodeList As Object
    Dim node As Object
    Dim result As Variant
    Dim i As Long
   
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.SetProperty "SelectionLanguage", "XPath"
    xmlDoc.async = False
    xmlDoc.LoadXML XMLData
   
    Set nodeList = xmlDoc.SelectNodes(XPath)
   
    If nodeList.Length > 0 Then
        ReDim result(0 To nodeList.Length - 1)
        i = 0 ' Dodana deklaracja i inicjalizacja zmiennej i
        For Each node In nodeList
            result(i) = node.Text
            i = i + 1
        Next node
    End If
   
    FilterXMLData = result
End Function


Function Status_HTTP(ByVal StatusCode As Long) As String
    Select Case StatusCode
        Case 400
            Status_HTTP = "Bad Request (Błąd żądania)"
        Case 401
            Status_HTTP = "Unauthorized (Nieautoryzowany)"
        Case 403
            Status_HTTP = "Forbidden (Zabronione)"
        Case 404
            Status_HTTP = "Not Found (Nie znaleziono)"
        Case 500
            Status_HTTP = "Internal Server Error (Wewnętrzny błąd serwera)"
        Case Else
            Status_HTTP = "Nieznany błąd HTTP"
    End Select
End Function

ID posta: 428809 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2021
Pomógł: 2607 razy
Posty: 8689
Wysłany: 05-07-2023, 12:11   

Ad 1.

Wygląda na to, że funkcja FilterXML próbuje rozpoznać daty w danych XML, których dotyczy zapytanie, i konwertuje dane XML, zanim dane zostaną wysłane do komórki.
Nie możemy również zmienić formatu argumentu Xpath , więc nie możemy kontrolować danych wyjściowych.
Jednym z rozwiązań może być delikatna zmiana XML-a zanim trafi do funkcji.

W kodzie po instrukcji
Kod:
 Resp = Replace(Resp, vbLf, "")
dopisz jeszcze to:
Kod:
Resp = Replace(Resp, "<NrNieruchomosci>", "<NrNieruchomosci>'")


FilterXML taki zapis 12/14 rozpoznaje jako datę i dlatego dochodzi do niejawnej konwersji.
Liczba 45274 to data 14.12.2023


Ad. 2
W pliku GUS_v2 umieściłem 2 kody
1. wersja testowa , która ma ograniczenia
2 wersja Produkcyjna , która nie ma ograniczeń - no chyba że API w jakiś sposób to ogranicza, nie wczytywałem się w to za bardzo.
Aby korzystać z wersji Produkcyjnej konieczne jest wpisanie do kodu poprawnego klucza
Kod:
Const My_Key As String = "xxxxxxxxxxxxxxx"    'Tu wpisz swój klucz z GUS-u
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 428810 Skopiuj do schowka
 
 
partner2001 
Exceloholic


Wersja: Win Office 365
Posty: 206
Wysłany: 08-12-2023, 19:46   

Witaj Marecki.
A jak zmodyfikowć ten kod aby procedura pobierała tylko dane które sa puste. Pobieranie wszystkich danych w przypadku dużej liczby podmiotów jest czasochłonne. Czy można ominąc pobieranie juz pobranych danych?
_________________
Dziękuję za pomoc.
Pozdrawiam
Leszek
ID posta: 432028 Skopiuj do schowka
 
 
Tajan


Pomógł: 5407 razy
Posty: 11795
Wysłany: 08-12-2023, 20:41   

Po linii:
Kod:
For i = 2 To Arkusz1.Cells(Arkusz1.Rows.Count, 1).End(xlUp).Row

wstaw:
Kod:
If Not Arkusz1.Cells(i, 2).Value = "" Then

a dalej, przed linią:
Kod:
Next i
wstaw
Kod:
End If

To spowoduje, że dla wierszy w których kolumna REGON jest wypełniona, kod nie zostanie wykonany.
ID posta: 432030 Skopiuj do schowka
 
 
partner2001 
Exceloholic


Wersja: Win Office 365
Posty: 206
Wysłany: 09-12-2023, 07:42   

Wstawiłem kody tak jak podałeś, ale po wstawieniu procedura wogóle nie pobiera danych.
Kod po wstawieniu wygląda tak
Kod:
Option Explicit

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


    'Koperta do logowania
    Soap = Soap & "<soap:Envelope xmlns:soap=""http://www.w3.org/2003/05/soap-envelope"" xmlns:ns=""http://CIS/BIR/PUBL/2014/07""> <soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">"
    Soap = Soap & "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/Zaloguj</wsa:Action>"
    Soap = Soap & "<wsa:To>https://wyszukiwarkaregon.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc</wsa:To>"
    Soap = Soap & "</soap:Header><soap:Body><ns:Zaloguj><ns:pKluczUzytkownika>" & My_Key & "</ns:pKluczUzytkownika></ns:Zaloguj></soap:Body></soap:Envelope>"

    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

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

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

        sID = Dane(0)
    End With

    Erase Dane

    '***************   Pobieramy właściwe dane
    For i = 2 To Arkusz9.Cells(Arkusz9.Rows.Count, 1).End(xlUp).Row
    If Not Arkusz9.Cells(i, 2).Value = "" Then
        With objXml
            Nip = Arkusz9.Cells(i, 1).Value

            'Koperta dla nip
            Soap = "<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 = Soap & "<soap:Header xmlns:wsa=""http://www.w3.org/2005/08/addressing"">"
            Soap = Soap & "<wsa:To>https://wyszukiwarkaregontest.stat.gov.pl/wsBIR/UslugaBIRzewnPubl.svc</wsa:To>"
            Soap = Soap & "<wsa:Action>http://CIS/BIR/PUBL/2014/07/IUslugaBIRzewnPubl/DaneSzukajPodmioty</wsa:Action>"
            Soap = Soap & "</soap:Header><soap:Body><ns:DaneSzukajPodmioty><ns:pParametryWyszukiwania><dat:Nip>" & Nip & "</dat:Nip></ns:pParametryWyszukiwania></ns:DaneSzukajPodmioty></soap:Body></soap:Envelope>"

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

        Resp = Replace(Resp, vbLf, "")
        Resp = Replace(Resp, "<NrNieruchomosci>", "<NrNieruchomosci>'")
        Dane = RegEx_Tab("<dane>(.*?)<\/dane>", Resp)
        Dane(0) = "<dane>" & Dane(0) & "</dane>"

        With Application
            Cells(i, 2).Value = .FilterXML(Dane(0), "//Regon")
            Cells(i, 3).Value = .FilterXML(Dane(0), "//Nazwa")
            Cells(i, 4).Value = .FilterXML(Dane(0), "//Miejscowosc")
            Cells(i, 5).Value = .FilterXML(Dane(0), "//Ulica")
            Cells(i, 6).Value = .FilterXML(Dane(0), "//NrNieruchomosci")
            Cells(i, 7).Value = .FilterXML(Dane(0), "//NrLokalu")
            Cells(i, 8).Value = .FilterXML(Dane(0), "//KodPocztowy")
            Cells(i, 9).Value = .FilterXML(Dane(0), "//MiejscowoscPoczty")
        End With
        End If
    Next i

    Set objXml = Nothing
    Erase Dane

End Sub
_________________
Dziękuję za pomoc.
Pozdrawiam
Leszek
ID posta: 432034 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.wip.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