Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 След.
Получить html код элемента
 
Добрый день! В файле-примере выводится html код страницы сайта. Помогите сделать макрос чтобы выводился не html код страницы, а html код конкретного элемента (блока, контейнера) "head", как на скринах. Спасибо!
Скрытый текст


Код
Function GetHTTPResponse(ByVal sURL As String) As String
 Dim oXMLHTTP As Object
    On Error Resume Next
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
        GetHTTPResponse = .responseText
    End With
    Set oXMLHTTP = Nothing
End Function

Sub HTML_Text()
Dim Text$
    Text = GetHTTPResponse("https://www.binance.com/en/trade/BTC_USDT?layout=basic")
    ThisWorkbook.Sheets(1).Range("A5") = Text
End Sub
Изменено: OSA913 - 17.10.2021 13:06:53
Крипто биржи - парсинг курсов
 
Требуется код для извлечения курсов из списка 28 криптобирж (список в загруженном файле). Бюджет предлагаете вы.
Нужно реализовать таблицей, где в первом столбце-названия бирж, во втором-валюта 1, в третьем-валюта 2, в четвертом-курс. При смене валюты в ячейке второго/третьего столбца и после нажатия на кнопку с макросом должен подгружаться курс.
Изменено: OSA913 - 11.05.2021 01:12:24
Извлечь текст из html элемента
 
Привет! Я пытаюсь извлечь текст из элемента, но получаю ошибку на строке с querySelector. Помогите разобраться. Извлекаю курс BTC/USD на бирже ByBit.
HTML:
Код
...
</div>
<span class="chart__head-left--price long">59289.50</span>
</div>
...

VBA:
Код
Dim html As HTMLDocument

    Set html = New HTMLDocument

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.bybit.com/trade/inverse/BTCUSD", False
        .send
        html.body.innerHTML = .responseText
    End With
    Debug.Print html.querySelector("span.chart__head-left--price long").innerText

В теге слово "long" перед цифрами постоянно чередуется со словом "short"
Изменено: OSA913 - 10.05.2021 08:28:17
Ссылка на другой лист в формуле УФ если название листа указано в ячейке
 
Как в формуле УФ обратиться к листу, если название листа отображено в ячейке?
В формуле 'название листа'! - работает, а 'ячейка с названием' ! - ошибка.
Бекап/Импорт отдельных нескольких листов книги
 
Здравствуйте, в книге 4 листа, у меня есть код, который сохраняет и импортит только 1 лист из книги. Помогите поправить код, что бы был бекап и так же импорт 3х последних листов с сохранением названий этих листов. Файл пример приложил.
Код:
Код
Sub Backup()
Application.ScreenUpdating = False
Dim FileName$
If MsgBox("Backup?", vbQuestion + vbYesNo, "Backup") = vbNo Then
        Exit Sub
    Else
        Application.ThisWorkbook.Sheets(2).Unprotect ("")
        On Error Resume Next
        FileName = Application.GetSaveAsFilename(".xlsx", "Excel (*.xlsx),", , , Empty)
        If FileName = "False" Then GoTo Ex
        Err.Clear: ThisWorkbook.Sheets(2).Copy: DoEvents
        If Err Then GoTo Ex
        If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
            Application.DisplayAlerts = False
            Application.EnableEvents = False
            ActiveWorkbook.SaveAs FileName, xlOpenXMLWorkbook
            ActiveWorkbook.DisplayAlerts = True
            Application.EnableEvents = True
            ActiveWorkbook.Close False
            If Err = 1004 Then GoTo Ex
            MsgBox "Created!", 64, "Backup"
        End If
    End If
Ex: Application.ThisWorkbook.Sheets(2).Protect (""), UserInterfaceOnly:=True
Application.ScreenUpdating = True
End Sub

Sub Import()
Application.ScreenUpdating = False
Dim i$, j&, k&
    If MsgBox("Replace?", vbQuestion + vbYesNo, "Import") = vbNo Then
        Exit Sub
    Else
        Application.ThisWorkbook.Sheets(2).Unprotect ("")
        On Error GoTo Ex
        Workbooks.Open FileName:=Application.GetOpenFilename
        i = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        j = ThisWorkbook.Sheets(2).UsedRange.Rows.Count + 1
        k = GetObject(i).Sheets(1).UsedRange.Rows.Count + 1
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        GetObject(i).Sheets(1).Range(Cells(2, 1), Cells(k, 197)).Copy: GetObject(i).Close
        Application.DisplayAlerts = True
        Application.EnableEvents = True
        ThisWorkbook.Sheets(2).Activate
        ThisWorkbook.Sheets(2).Range(Cells(2, 1), Cells(j, 197)).ClearContents
        ThisWorkbook.Sheets(2).Range("A2").Select: ActiveSheet.Paste
        ThisWorkbook.Sheets(1).Activate
        Application.Caption = IIf(False = True, Empty, "")
        Application.DisplayStatusBar = False
        MsgBox "Imported!", 64, "Import"
Ex:         Application.ThisWorkbook.Sheets(2).Protect (""), UserInterfaceOnly:=True: ThisWorkbook.Save
    End If
Application.ScreenUpdating = True
End Sub
Вызвать макрос при изменении ячеек
 
Здравствуйте, помогите с кодом. Нужно чтобы при изменении значения в определённой ячейки в диапазоне срабатывал определённый макрос, и так же чтобы макрос срабатывал когда значение в ячейке удаляется delete-ом.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Union(Cells(2, 37), Range(Cells(4, 38), Cells(16, 38)))) Is Nothing Then
    Select Case Range
        Case Cells(2, 37)
            Call Макрос1
        Case Cells(4, 38)
            Call Макрос2           
        Case Cells(5, 38)
            Call Макрос3
        Case Cells(6, 38)
            Call Макрос4
    End Select
End If
End Sub
Заполнить отдельные элементы VBA массива одним значением
 
Есть ли какая нибудь функция типа Union для диапазонов листа, только для элементов VBA массива?
Задача заполнить отдельные элементы массива одним значением в одной строке кода.
Назначить горячую клавишу только Ctrl
 
Можно назначить макрос только на кнопку контрол? Этим способом:
Код
Private Sub Workbook_Open()
Application.OnKey "{^}", "Макрос"
End Sub

не работает. Подозреваю что кнопку надо как то назначать через WinApi.
Закрасить ячейку, если диапазон не содержит нужного значения или значение не отвечает заданным требованиям
 
Есть две формулы в двух правилах УФ:
Код
=СУММ(СЧЁТЕСЛИМН(ИНДЕКС($F:$K;ПОИСКПОЗ(B2;E:E;););1;ИНДЕКС($F:$K;ПОИСКПОЗ(B2;E:E;););2;ИНДЕКС($F:$K;ПОИСКПОЗ(B2;E:E;););""))=6
,
Код
=ЕНД(ПОИСКПОЗ(B2;E:E;))

Можно ли эти формулы объединить в одну, чтобы было одно правило в место двух? Как бы это сделать?
Получить адрес диапазона ячеек в формуле
 
В ячейке B4 нужно подсчитать количество единичек в диапазоне. В файле-примере нужно значение B2 ("qqq") найти в первой колонке таблицы, затем получить диапазон, который находится в этой же стоке что и ячейка с этим значением, смещенный на один столбец вправо и имеющий 6 ячеек и подсчитать ячейки с "1" в этом диапазоне. В примере этот диапазон "F6:K6". Как это реализовать в формуле?
Формула УФ - если в диапазоне присутствуют только некоторые значения
 
Здравствуйте. Помогите с формулой для УФ.
Если в диапазоне B1:J1 есть только значения "", 1, 2, тогда ячейка A1 меняет цвет.
Срабатывание макроса при наведении мыши с нажатой кнопкой на кнопку макроса
 
Есть ли возможность вызвать макрос просто наведя мышь с нажатой ЛКМ на фигуру, которой назначен сей макрос?
Если есть, тогда как это можно реализовать?
Изменено: OSA913 - 19.12.2019 06:38:06
Countif для vba массива
 
Пример кода:
Код
Sub Test()
Dim MyArr(3)
MyArr(0) = 0
MyArr(1) = 0
MyArr(2) = 1
MyArr(3) = 1
Test = Application.WorksheetFunction.CountIf(MyArr, 0)
End Sub

Если в первом аргументе, поставить не диапазон на листе, а массив VBA, то VBA выдаст сообщение о ошибке.
Какая есть альтернатива WorksheetFunction.CountIf, что бы можно было бы использовать только VBA массив в аргументе (не выводить на лист)?
Back up таблиц в новый файл
 
Нужно создать новый документ и скопировать 2 таблицы из основного документа. 1ю таблицу в новом созданном файле поместить на "A1", 2ю таблицу - на "H1".
Написал примерный код, но он даже не сохраняет новый документ.
Код
Sub Backup()
Dim Filename$
    If MsgBox("Back up?", vbQuestion + vbYesNo, "Back up") = vbNo Then
        Exit Sub
    Else
        Application.ActiveSheet.Unprotect ("")
        On Error Resume Next
        Filename = Application.GetSaveAsFilename(".xlsx", "Excel (*.xlsx),", , , Empty)
        If Filename = "False" Then GoTo Ex
        GetObject(Filename).SaveAs Filename, xlOpenXMLWorkbook
        MsgBox "Back up created!", 64, "Back up"
    End If
Ex:
Application.ThisWorkbook.ActiveSheet.Protect (""), UserInterfaceOnly:=True
End Sub
Изменено: OSA913 - 19.04.2019 03:26:16
Экспорт таблицы в выбранную книгу
 
Доброе утро. Нужно макросом экспортировать таблицу в другую выбранную книгу. Не весь лист, а только диапазон, в котором таблица. Мой код почему то не работает. Помогите пожалуйста.
Это мой не рабочий код:
Код
Sub Stats_Export()
Dim Filename$
    If MsgBox("Export Stats?", vbQuestion + vbYesNo, "Export Stats") = vbNo Then
        Exit Sub
    Else
        Application.ActiveSheet.Unprotect ("")
        On Error GoTo Ex
        ThisWorkbook.ActiveSheet.Range(Cells(4, 13), Cells(53, 30)).Copy
        Workbooks.Open Filename:=Application.GetOpenFilename
        ActiveWorkbook.ActiveSheet.Range(Cells(4, 5), Cells(53, 22)).ClearContents
        ActiveWorkbook.ActiveSheet.Range("E4").Select
        ActiveWorkbook.ActiveSheet.Paste
        ActiveWorkbook.Close
        MsgBox "Stats exported", 64, "Export Stats"
    End If
Ex:
Application.ActiveSheet.Protect (""), UserInterfaceOnly:=True
End Sub
VBA, Проверка диапазона на наличие определенных значений в ячейках
 
Добрый вечер, Нужен vba код. Если хотя бы одна ячейка в диапазоне A1:D25 имеет значение меньше 0 и больше 14, тогда макрос не выполняется, но если есть пустые ячейки, и нет ячеек со значением меньше 0 и больше 14, тогда выполняется. Спасибо.
VBA функция для переноса значений из ячеек в заданном диапазоне
 
В аргументах функции - диапазон. Функция должна переносить значения из ячеек в ячейки ниже в указанном диапазоне.
Написал такую, но что то не работает (выделяет переменную Num).  Файл-пример приложил. Поправьте пожалуйста.
Код
Function Stats(Rng As Range)
Dim CellCount, Num As Integer
Dim Cl(Num) As Object

Cl = Activesheet.Rng.Cells
CellCount = Rng.Cells.Count

    For Num = CellCount To 1
        Cl(Num).Value = Cl(Num - 1).Value
    Next Num

End Function
VBA несколько ячеек в условии if
 
Помогите, а то уже все забыл) Как правильно записать диапазон из нескольких ячеек в условии? Я записал:
Код
If ActiveSheet.Range("B5, B7, B9, B11").Value <> "-" Then

Условие не выполняется только когда ячейка "B5" содержит значение "-", а нужно чтобы оно не выполнялось когда в любой из этих ячеек  "-".
Изменено: OSA913 - 13.03.2019 08:09:18
Подключить DLL(C++) к VBA
 
Здравствуйте, создал тестовую DLL с помощью def файла:
Код С++ (*.cpp)
Код
 
double __stdcall square(double & x)
{
   return x * x;
}

Код С++ (*.def)
Код
 
LIBRARY "square"
EXPORT
square

Затем пытаюсь подключить к VBA так:
Код
Declare PtrSafe Function square _
Lib "C:\Users\OSA\source\repos\square\x64\Debug\square.dll" _
(ByRef x As Double) As Double

В ячейке пишу формулу с подключенной функцией "square":
Код
=square(10)
И в ячейке получаю ошибку "ЗНАЧ!"
Использую Excel 2016 x 64. Помогите разобраться где ошибка.
Защитить проект от распространения
 
Здравствуйте! Нужно максимально надежно защитить проект таким образом чтобы он открывался только на компьютере владельца. Так же нужно максимально защитить макросы.
Защиту сделать на образце. Защита не должна отражаться на скорости макросов.
Сохранение области на листе в отдельный файл
 
Здравствуйте! Есть код в котором макрос сохраняет лист в отдельный файл:
Код
Option Explicit
Sub Sheet_Backup()
Dim Filename$
Application.ActiveSheet.Unprotect ("")
    On Error Resume Next
     Filename = Application.GetSaveAsFilename("Sheet.xlsx", "Sheet Excel (*.xlsx),", , _
                                             "Saving file", "Save")
     If VarType(Filename) = vbBoolean Then Exit Sub
     Err.Clear: ActiveSheet.Copy: DoEvents
     If Err Then Exit Sub
     If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
     ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook
     ActiveWorkbook.Close False
    End If
Application.ActiveSheet.Protect ("")
End Sub

Помогите исправить код, 1. чтобы сохранялся не лист, а только диапазон с желтыми ячейками;
2. чтобы при нажатии на "отмена" в окне сохранения файла, файл не сохранялся.
Массово заменить ссылку в УФ
 
Здравствуйте, есть много ячеек, каждая ячейка содержит много правил УФ. Нужно в каждой формуле УФ заменить текст "#ССЫЛКА!" на "$T$2". Как это можно сделать чтобы не в ручную?
Задать положение окна приложения в зависимости от размера экрана
 
Здравствуйте, Имеется файл, при открытии которого, окно приложения должно становиться в правом нижнем углу экрана. Т.к. он открывается на разных компьютерах, нужно определить размер экрана, что бы определить координаты расположения окна приложения.
Нашел на другом форуме код который определяет размер:
Код
Dim x As Variant, a#, b#
With GetObject("winmgmts:\\.\root\cimv2")
    For Each x In .ExecQuery("Select * From Win32_DisplayConfiguration")
        a = x.PelsWidth
        b = x.PelsHeight
    Next
End With

И проверил сперва на большом мониторе, затем на другом компьютере с меньшим монитором, и оказалось что в режиме отладки на меньшем мониторе значения a и b те же что и на большом мониторе. Может этот код не то, что нужно для моей цели? Подскажите как программно определить размер экрана? Файл с неработающим кодом прилагаю.
Посчитать ячейки в диапазоне не равные 0
 
Здравствуйте, как присвоить переменной число равное количеству ячеек в диапазоне со значением не равным 0?
Пытался так:
Код
Dim k As Byte
k = Range("A1:A10").Value<>0.Count

vba ругается.
Определения вероятности занять место в турнире по покеру игроками, исходя из количества фишек у игроков, сократить формулу
 
Здравствуйте, помогите решить задачу. В примере в ячейке H3 нужно получить такой же результат, как в ячейке G3:
Скрытый текст

используя какую нибудь функцию, примерно как результат формулы из ячейки E3:
Скрытый текст

получился  в ячейке F3:
Скрытый текст

Цель - максимально сократить формулу. Если встроенными функциями никак не решаемо, тогда помогите пожалуйста сделать пользовательскую. Спасибо.
Размещение без повторений значений ячеек
 
Здравствуйте, в примере генерируются размещения n элементов по m элементов. Сгенерированные элементы выражаются числами по порядку. В примере в ячейку L3 вводится количество элементов, в L4 - по сколько элементов размещать. Помогите поправить код чтобы в качестве элементов были не числа по порядку, а значения ячеек из диапазона L10:L19. Заранее благодарю.
Кросс
Запись длинных формул в функцию vba
 
Здравствуйте! Попытаюсь максимально подробно объяснить чего хочу, т.к. нет возможности вставить пример.
Есть динамическая таблица на листе, в которой закрашиваются ячейки в зависимости от выбранного имени таблицы (закраска ячеек происходит при выборе имени таблицы). Имена таблиц вместе со значениями, указывающими какую ячейку выбранной таблицы в какой цвет залить хранятся в базе на другом листе. Есть ячейки, в которых выводится процент ячеек, залитых определенным цветом. Вначале я создал массив на отдельном листе , в  нем получилось много ячеек с длинными формулами, и общий результат вычислений в этом массиве выводился в ячейки на листе вместе с таблицей. Вот пример формулы одной из ячеек массива с множеством условий:
Скрытый текст

Для увеличения скорости обработки данных  решил перенести все вычисления в vba, а только в ячейки выводить общий результат.
Создал функцию в vba, в которую попытался запихнуть такую длинную формулу:
Код
Option explicit
Function Test()
Test=Evaluate("="длинная формула в англ. варианте"")
End Function 

Не получилось, думаю из-за того, что в скобках стоит ограничение на 255 символов.
Подскажите метод чтобы можно было впихнуть всю формулу не разбивая ее на множество функций. Заранее благодарен.
Автозаполнение графика именами из списка по порядку, с игнорированием пустых ячеек.
 
Здравствуйте! Есть имена в диапазоне B2:B13, между ними пустые ячейки. Имена в этом списке периодически меняются как и пустые ячейки. Ниже-график, где под понедельником в ручную выбирается имя из выпадающего списка .
Как сделать чтобы после выбора имени, в строке под Вт-Вс становились имена по порядку из списка в диапазоне B2:B13, при этом игнорировались пустые ячейки?
ПС: Попытался вставить формулу под вторником, она работает только если нет пустой ячейки, и не "перепрыгнет" вверх, если будет выбрано последнее в списке имя.
Заливка ячейки при изменении на листе в зависимости от значения ячейки
 
Поправьте пожалуйста код в "Private Sub Worksheet_Change", чтобы функция работала.

Код
Function test()
Cell.Interior.Color = 255
End Function


Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("A2") = 1 Then
Range("A1") = test
End If
If Range("A2") = 2 Then
Range("B1") = test
End If
If Range("A2") = 3 Then
Range("C1") = test
End If
End Sub
Изменено: OSA913 - 18.10.2017 16:42:49
Пропал левый бордюр в окне кода
 
Подскажите как его вернуть.
Страницы: 1 2 След.
Наверх