Загрузка файла VBA с логином не работает

Вы отправляете данные для входа на неверный адрес для входа. Ваш правильный адрес для входа: https://pnds.health.ny.gov/account/login страница ожидает LoginName и Token. Токен генерируется с помощью SecurityManager.generate( u, p );

Вы по-прежнему можете проконсультироваться с их ИТ-командой, чтобы убедиться, что вы не нарушаете их политику.

Вот способ сделать это с помощью объекта браузера IE.

Private Sub DownloadValidationData()
'Create Internet explorer object
Dim IE As Object
Set IE = CreateObject("INTERNETEXPLORER.APPLICATION")

IE.Visible = True

Dim URL As String: URL = "https://pnds.health.ny.gov/account/login"

IE.Navigate URL
While IE.READYSTATE <> READYSTATE_COMPLETE
    DoEvents
Wend

Dim userName As String: userName = "test"
Dim password As String: password = "test"

'Fill the login form
IE.Document.getElementById("UniqueUser").Value = userName
IE.Document.getElementById("UniquePass").Value = password

'Submit the form
IE.Document.querySelector("button.SignIn").Click

'Wait for login to complete
While IE.READYSTATE <> READYSTATE_COMPLETE
    DoEvents
Wend
'Verify you are logged in: As we don't know what the site looks like after login in. Only you can do this step.

'Navigate to Download Page. This should prompt to save the file.
IE.Navigate theDownloadUrl '"https://pnds.health.ny.gov/xxxx/xxxx/8"

'Once downloaded just close the browser and exit
'IE.Quit
'Set IE = Nothing


'If you are interested in geting/generating the token using their script you can play around with below lines. These lines come before loging in. Please note: execScript is depreciated now

'Dim Token as string
'IE.Document.parentwindow.execScript ("$('#Token').val(SecurityManager.generate(""" & username & """, """ & password & """ ))")
'Token = IE.Document.getElementById("Token").Value
'Use the token to sign in using your code. That'll be xobj.Send "LoginName =" & userName & "&Token=" & Token
'But not sure if it will work.



End Sub

Я бы сделал небольшую рекурсивную функцию, которая проверяет перенаправления до тех пор, пока их не останется.

Так:

Option Explicit
Const WinHttpRequestOption_EnableRedirects = 6

Public Function GetRedirect(ByRef oHttp As Object, ByVal strUrl As String) As String
    With oHttp
        .Open "HEAD", strUrl, False
        .Send
    End With

    If oHttp.Status = 301 Or oHttp.Status = 302 Or oHttp.Status = 303 Then
        GetRedirect= GetRedirect(oHttp, oHttp.GetResponseHeader("Location"))
    Else
        GetRedirect= strUrl
    End If
End Function

Sub DownloadFile2(myURL As String)

    Dim CurrentProject
    Dim CurPath As String

    CurPath = CurrentProject.Path & "\"
    Dim strCookie As String, strResponse As String, _
    strUrl As String
    Dim xobj As Object
    Dim WinHttpReq As Object
    Set xobj = CreateObject("WINHTTP.WinHTTPRequest.5.1")
    Dim UN As String
    UN = "hhhhh"
    Dim PW As String
    PW = "gggg"

    strUrl = "https://pnds.health.ny.gov/login"
    With xobj
        .Open "POST", strUrl, False
        .SetRequestHeader "Connection", "keep-alive"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send "&username=" & UN & "&password=" & PW & "&login=login"
    End With

    strUrl = GetRedirect(xobj, myURL)

    If xobj.Status = 200 Then
        Dim oStream As Object
        Set oStream = CreateObject("ADODB.Stream")
        With oStream
            .Open
            .Type = 1
            .Write xobj.ResponseBody
            .SaveToFile CurPath & "ValidationDataHFIS.csv", 2 ' 1 = no overwrite, 2 = overwrite
            .Close
        End With
    End If
End Sub

Sub ddd()

    DownloadFile2 ("https://pnds.health.ny.gov/xxxx/xxxx/8")
End Sub

ПРИМЕЧАНИЕ. Этот код не тестировался, и его необходимо адаптировать для вашего варианта использования.