VBA: Wert von einer Website (pdf-Dokument) auslesen und in Excel kopieren

Sub ExtractData()
    Dim strURLGetDate As String, strTempHTML As String, strTempPDF As String, fso As Object, regex As Object
    ' Paths  
    strURLGetDate = "https://www.ffiec.gov/nicpubweb/nicweb/InstitutionProfile.aspx?parID_Rssd=######&parDT_END=99991231"  
    strTempHTML = Environ("TEMP") & "\extract_date.html"  
    strTempPDF = Environ("TEMP") & "\report.pdf"  
    'Objects  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    regex.IgnoreCase = True
    
    With ActiveSheet
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            ' Lade Seite mit den Datumswerten für den Report  
            If DownloadFile(Replace(strURLGetDate, "######", cell.Value, 1, 1, vbTextCompare), Environ("TEMP") & "\extract_date.html") Then  
                'extrahiere das Datum  
                strContent = fso.OpenTextFile(strTempHTML, 1, False, -2).ReadAll()
                regex.Pattern = "selected=""selected"" value=""([\d-]+)"""  
                Set matches = regex.Execute(strContent)
                If matches.Count > 0 Then
                    strDate = Replace(matches(0).submatches(0), "-", "", 1, -1, 1)  
                    ' trigger Report creation  
                    DownloadFile "https://www.ffiec.gov/nicpubweb/nicweb/FinancialReport.aspx?parID_RSSD=" & cell.Value & "&parDT=" & strDate & "&parRptType=FFIEC002&redirectPage=FinancialReport.aspx", strTempHTML  
                    'PDF Download URL  
                    strPDFURL = "https://www.ffiec.gov/nicpubweb/NICDataCache/FFIEC002/FFIEC002_" & cell.Value & "_" & strDate & ".PDF"  
                    ' Downloade PDF, extrahiere den gewünschten Wert und schreibe Ihn in die Zelle neben der RSSD-ID  
                    If DownloadFile(strPDFURL, strTempPDF) Then
                        cell.Offset(0, 1).Value = ExtractXMLFormData(strTempPDF)
                    End If
                End If
            End If
        Next
    End With
    MsgBox "Finished", vbInformation  
End Sub

'Funktion zum Herunterladen von Dateien  
Function DownloadFile(ByVal strURL As String, ByVal strTarget As String) As Boolean
    On Error GoTo Error
    Dim objhttp As Object, objStream As Object
    Set objhttp = CreateObject("Microsoft.XMLHTTP")  
    Set objStream = CreateObject("ADODB.Stream")  
    With objhttp
        .Open "GET", strURL, False  
        .send
        If .Status = 200 Then
            objStream.Open
            objStream.Type = 1
            objStream.Write .responseBody
            objStream.SaveToFile strTarget, 2 'Overwrite target  
            objStream.Close
            DownloadFile = True
        Else
            DownloadFile = False
        End If
    End With
    Exit Function
Error:
    DownloadFile = False
End Function

' XML-FormData per Acrobat JavaScript Object extrahieren  
Function ExtractXMLFormData(ByVal strPath As String) As String
    On Error GoTo Err
    Set objAcro = CreateObject("AcroExch.App")  
    Set docAV = CreateObject("AcroExch.AVDoc")  
    Set docPD = CreateObject("AcroExch.PDDoc")  
    
    docAV.Open strPath, ""  
    Set docPD = docAV.GetPDDoc()
    Set jsDoc = docPD.GetJSObject()
    ExtractXMLFormData = jsDoc.xfa.form.F.P8.Subform1.RCFD3149.rawValue
    jsDoc.closeDoc
    
    Set jsDoc = Nothing
    Set docPD = Nothing
    Set docAV = Nothing
    Set objAcro = Nothing
    Exit Function
Err:
    Set jsDoc = Nothing
    Set docPD = Nothing
    Set docAV = Nothing
    Set objAcro = Nothing
    ExtractXMLFormData = ""  
End Function

Sub ExtractData()
    Dim strURLGetDate As String, strTempHTML As String, strTempPDF As String, fso As Object, regex As Object
    ' Paths  
    strURLGetDate = "https://www.ffiec.gov/nicpubweb/nicweb/InstitutionProfile.aspx?parID_Rssd=######&parDT_END=99991231"  
    strTempHTML = Environ("TEMP") & "\extract_date.html"  
    strTempPDF = Environ("TEMP") & "\report.pdf"  
    'Objects  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    regex.IgnoreCase = True
    
    With ActiveSheet
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            ' Lade Seite mit den Datumswerten für den Report  
            If DownloadFile(Replace(strURLGetDate, "######", cell.Value, 1, 1, vbTextCompare), Environ("TEMP") & "\extract_date.html") Then  
                'extrahiere das Datum  
                strContent = fso.OpenTextFile(strTempHTML, 1, False, -2).ReadAll()
                regex.Pattern = "selected=""selected"" value=""([\d-]+)"""  
                Set matches = regex.Execute(strContent)
                If matches.Count > 0 Then
                    strDate = Replace(matches(0).submatches(0), "-", "", 1, -1, 1)  
                    If strDate = .Range("B1").Value Then  
                        ' trigger Report creation  
                        DownloadFile "https://www.ffiec.gov/nicpubweb/nicweb/FinancialReport.aspx?parID_RSSD=" & cell.Value & "&parDT=" & strDate & "&parRptType=FFIEC002&redirectPage=FinancialReport.aspx", strTempHTML  
                        'PDF Download URL  
                        strPDFURL = "https://www.ffiec.gov/nicpubweb/NICDataCache/FFIEC002/FFIEC002_" & cell.Value & "_" & strDate & ".PDF"  
                        ' Downloade PDF, extrahiere den gewünschten Wert und schreibe Ihn in die Zelle neben der RSSD-ID  
                        If DownloadFile(strPDFURL, strTempPDF) Then
                            cell.Offset(0, 1).Value = ExtractXMLFormData(strTempPDF)
                        End If
                    End If
                End If
            End If
        Next
    End With
    MsgBox "Finished", vbInformation  
End Sub

Option Explicit
Option Compare Text

Private Const RowStart = 3          'Bei Bedarf anpassen  
Private Const RngDates = "B2:E2"    'Bei Bedarf anpassen  

Private Const PatternDates = "<option[\D]*([^""]+)"  
Private Const PatternValue = "All other banks.*Column A[\D]*3149[\D]*(\d+)"  

Private Const UrlGetDate = "https://www.ffiec.gov/nicpubweb/nicweb/InstitutionProfile.aspx?parID_Rssd=%1&parDT_END=99991231"  
Private Const UrlGetReady = "https://www.ffiec.gov/nicpubweb/nicweb/FinancialReport.aspx?parID_RSSD=%1&parDT=%2&parRptType=FFIEC002&redirectPage=FinancialReport.aspx"  
Private Const UrlGetPDF = "https://www.ffiec.gov/nicpubweb/NICDataCache/FFIEC002/FFIEC002_%1_%2.PDF"  

Private objRegExp As Object, objHttpRequest As Object

'Diese Function aktualsiert alle noch austehende Werte (B:E), d.h. alle leere Zellen, bei denen  
'das Spaltendatum (B2:E2) im Zeitfenster des aktuellen Datums liegt und ein Report bereit steht.  
'Vorausgesetzt, dass jeweilige Datum ist in der Standardform TT.MM.JJJJ z.B. 1.3.2016 eingetragen.  
'Das Zellformat kann allerdings nach Belieben festgelegt werden.  
Private Sub BtnRefresh_Click()
    Dim objCells As Range, objDate As Range, objTarget As Range
    
    Set objRegExp = CreateObject("VBScript.RegExp")  
    Set objHttpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")  
    
    'Alle RSSD-ID's in Spalte A abarbeiten  
    For Each objCells In Range(Cells(RowStart, "A"), Cells(Rows.Count, "A").End(xlUp))  
        'Test ob Zahlenwert  
        If IsNumeric(objCells.Value) Then
            'Alle Datumsspalten abarbeiten  
            For Each objDate In Range(RngDates)
                'Test ob Zelle ein Datum enthält und im Zeitfenster mit aktuellen Datum liegt  
                If objDate.Value > 0 And objDate.Value <= Date Then
                    'Aktuelle Zelle Zeile?/Spalte? fixieren  
                    Set objTarget = Cells(objCells.Row, objDate.Column)
                    'Test ob Zelle Leer ist  
                    If IsEmpty(objTarget.Value) Then
                        'Pdf-Wert ermitteln (Zahlenwert/Empty)  
                        objTarget.Value = GetValue(objCells.Value, objDate.Value)
                    End If
                End If
            Next
        End If
    Next
    Set objRegExp = Nothing
    Set objHttpRequest = Nothing
    MsgBox "Fertig!", vbInformation  
End Sub

'Diese Function gibt einen Wert (Zahl/Empty) in Abhängigkeit von RSSD-ID und Datum zurück.  
Private Function GetValue(ByRef strID, ByVal dblDate As Date) As Variant
    Dim objMatch As Object, objMatchDate As Object, strText As String
    Dim strDate As String, strUrlPDF As String, strUrlReady As String
    
    'Website mit Datumsangebote einlesen  
    strText = GetHttpRequest(Replace(UrlGetDate, "%1", strID))  
    
    If strText <> "" Then  
        'Datumsangebote (DropBox) erfassen  
        For Each objMatchDate In GetMatchesObject(strText, PatternDates, True)
            'Abfrage-Datum in Form JJJJMMTT erzeugen  
            strDate = Replace(objMatchDate.SubMatches(0), "-", "")  
            'Test Datum  
            If Left(strDate, 6) = Format(dblDate, "YYYYMM") Then  
                'Url's erzeugen  
                strUrlPDF = Replace(Replace(UrlGetPDF, "%1", strID), "%2", strDate)  
                strUrlReady = Replace(Replace(UrlGetReady, "%1", strID), "%2", strDate)  
                'Report erzeugen und testen ob Report bereit steht  
                If InStr(GetHttpRequest(strUrlReady), "report is ready") > 0 Then  
                    'PDF als Text einlesen  
                    strText = GetHttpRequest(strUrlPDF)
                    'Test ob Pdf-Einlesen erfolgreich  
                    If strText <> "" Then  
                        'Wert ermitteln  
                        For Each objMatch In GetMatchesObject(strText, PatternValue, False)
                            'Gegebenenfalls Kommastellenzeichen englisch/deutsch ersetzen  
                            GetValue = CDbl(Replace(objMatch.SubMatches(0), ".", ","))  
                        Next
                    End If
                    Exit For
                End If
            End If
        Next
    End If
End Function

'Diese Function gibt den Quelltext einer Website als Text oder Byte-Array zurück  
Private Function GetHttpRequest(ByRef strUrl, Optional ByVal bolByte As Boolean) As Variant
    Dim i As Integer
    
    On Error Resume Next
    With objHttpRequest
            For i = 1 To 3  'maximal 3 Versuche  
               .Open "Get", strUrl, False  
               .Send
                If .Status = 200 Then
                    GetHttpRequest = IIf(bolByte, .ResponseBody, .ResponseText):  Exit For
                End If
            Next
    End With
    On Error GoTo 0
End Function

'Diese Function gibt das Match-Object zurück  
Private Function GetMatchesObject(ByRef strText, ByRef strPattern, ByVal bolGlobal As Boolean) As Object
    With objRegExp
        .Global = bolGlobal
        .IgnoreCase = True
        .Pattern = strPattern
         Set GetMatchesObject = .Execute(strText)
    End With
End Function