Как в ссылке к формуле импорта ХМL сделать ссылку на данные из ячейки гугл-таблицы?, Связано с импортом данных из интерента, но какие именно данные необходимо импортировать, должно указываться ячейкой из таблицы
Кук в заголовках нет. По опыту, в такой ситуации, когда кук нет, я использую один экземпляр для нескольких запросов. Сбоя еще не было никогда.Как получить куки показал в коде. Сами убедитесь, что их нет.
Скрытый текст
Код
Private Function GetHTTPResponse() As String
Dim oXMLHTTP, cookie$, crumb$
sURL = "https://finance.yahoo.com/quote/AAPL?p=AAPL"
On Error Resume Next
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
With oXMLHTTP
.Open "GET", sURL, False
.SetRequestHeader "Cache-Control", "max-age=0"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/48.0.2564.41 Safari/537.36 OPR/35.0.2066.10 (Edition beta)"
.SetRequestHeader "Accept-Encoding", "deflate"
.SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
.SetRequestHeader "upgrade-insecure-requests", "1"
.send
cookie$ = ""
Dim header As Variant
Debug.Print .getAllResponseHeaders()
For Each header In Split(.getAllResponseHeaders(), vbNewLine)
If header Like "Set-Cookie:*" Then
cookie$ = cookie$ & "; " & Mid(header, 12)
End If
Next
crumb = get_crumb(.responseText)
.abort
sURL = "https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?modules=price&crumb=" & crumb
.Open "GET", sURL, False
.SetRequestHeader "Cache-Control", "max-age=0"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/48.0.2564.41 Safari/537.36 OPR/35.0.2066.10 (Edition beta)"
.SetRequestHeader "Accept-Encoding", "deflate"
.SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
.send
GetHTTPResponse = .responseText
Debug.Print .responseText
End With
Set oXMLHTTP = Nothing
End Function
Поправите под себя GetHTTPResponse Результат получил
Скрытый текст
Код
Private Function GetHTTPResponse() As String
Dim oXMLHTTP, cookie$, crumb$
sURL = "https://finance.yahoo.com/quote/AAPL?p=AAPL"
On Error Resume Next
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
With oXMLHTTP
.Open "GET", sURL, False
.SetRequestHeader "Cache-Control", "max-age=0"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/48.0.2564.41 Safari/537.36 OPR/35.0.2066.10 (Edition beta)"
.SetRequestHeader "Accept-Encoding", "deflate"
.SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
.SetRequestHeader "upgrade-insecure-requests", "1"
.send
crumb = get_crumb(.responseText)
.abort
sURL = "https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?modules=price&crumb=" & crumb
.Open "GET", sURL, False
.SetRequestHeader "Cache-Control", "max-age=0"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/48.0.2564.41 Safari/537.36 OPR/35.0.2066.10 (Edition beta)"
.SetRequestHeader "Accept-Encoding", "deflate"
.SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
.send
GetHTTPResponse = .responseText
Debug.Print .responseText
End With
Set oXMLHTTP = Nothing
End Function
Function get_crumb(sl As String) As String
With CreateObject("VBScript.RegExp")
.IgnoreCase = True
.Pattern = Chr(34) & "crumb""\:\s""(.+?)"","
Set oMatches = .Execute(sl)
If oMatches.Count > 0 Then
get_crumb = oMatches(0).subMatches(0)
Exit Function
End If
End With
End Function
Интерполяция треугольника используется для получения координат точки в области треугольника.. Вбейте в поиск в яндексе Интерполяция треугольника , есть некоторые решения.
По поводу повреждения макросом файла, макрос не виноват. 1.Где хранится файл ? 2.Кто с ним работает после выполнения макроса и закрытия книги ? На маке никто не работает с файлом? Идет замена модуля листа на модуль книги С выпадающим списком все понятно, Formula1:=Join(a, ",") На картинке видно, что с 2 значений появляется 4.объединение в строку прописано через запятую и других вариантов нет. Надо менять сам алгоритм
Sub CreateMarkdown()
Dim Sh As Worksheet, FileName$, folder$, strUnicode$
Set Sh = ThisWorkbook.Worksheets("Лист1")
LastRow = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
folder$ = ThisWorkbook.Path & "\1"
dx = Sh.Range("B1").Resize(LastRow, 2)
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(folder$) Then
.CreateFolder folder$
End If
For n = 1 To UBound(dx)
strUnicode$ = dx(n, 2)
FileName$ = dx(n, 1)
If FileName$ <> "" Then
FileName$ = .BuildPath(folder, FileName) & ".md"
Writer_To strUnicode, FileName
End If
Next
End With
End Sub
Sub Writer_To(strUnicode As String, FileName As String)
Const adTypeBinary = 1
Const adTypeText = 2
Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject")
Dim oTo: Set oTo = CreateObject("ADODB.Stream")
Dim sTo: sTo = "utf-8"
Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FileName)
If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec
oTo.Type = adTypeText
oTo.Charset = sTo
oTo.Open
oTo.WriteText strUnicode
oTo.SaveToFile sTFSpec
oTo.Close
Set oFS = Nothing
Set oTo = Nothing
End Sub
' Writer_SkipBOM запись без BOM , выберите нужную процедуру
Sub Writer_SkipBOM(strUnicode As String, FileName As String)
Const adTypeBinary = 1
Const adTypeText = 2
Dim oFS: Set oFS = CreateObject("Scripting.FileSystemObject")
Dim oTo: Set oTo = CreateObject("ADODB.Stream")
Dim sTo: sTo = "utf-8"
Dim sTFSpec: sTFSpec = oFS.GetAbsolutePathName(FileName)
If oFS.FileExists(sTFSpec) Then oFS.DeleteFile sTFSpec
oTo.Type = adTypeText
oTo.Charset = sTo
oTo.Open
oTo.WriteText strUnicode
oTo.Position = 3
Dim BinaryStream As Object
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = 1
BinaryStream.Mode = 3
BinaryStream.Open
oTo.CopyTo BinaryStream
oTo.Flush
oTo.Close
BinaryStream.SaveToFile sTFSpec, 2
BinaryStream.Close
Set oTo = Nothing
Set BinaryStream = Nothing
End Sub
[ Закрыто] Гугл таблицы, Сделать множественный выпадающий список, но чтобы в ячейке можно было выбрать несколько значений и они перечислялись через запятую